diff --git a/package-data-list.lisp-expr b/package-data-list.lisp-expr
index 2162fd387..0cb70db11 100644
--- a/package-data-list.lisp-expr
+++ b/package-data-list.lisp-expr
@@ -2067,7 +2067,7 @@ is a good idea, but see SB-SYS re. blurring of boundaries."
                "TYPE-*-TO-T"
                "TYPE-DIFFERENCE" "TYPE-INTERSECTION"
                "TYPE-INTERSECTION2" "TYPE-APPROX-INTERSECTION2"
-               "TYPE-SINGLETON-P"
+               "TYPE-SINGLETON-P" "TYPE-CONSTANT-CONS-P"
                "TYPE-SINGLE-VALUE-P" "TYPE-SPECIFIER" "TYPE-UNION"
                "TYPE/=" "TYPE=" "TYPES-EQUAL-OR-INTERSECT"
                "TYPE-OR-NIL-IF-UNKNOWN"
diff --git a/src/code/late-type.lisp b/src/code/late-type.lisp
index b3808a47d..df6b41a3d 100644
--- a/src/code/late-type.lisp
+++ b/src/code/late-type.lisp
@@ -1188,6 +1188,30 @@
         (funcall function type)
         (values nil nil))))
 
+;;; CONSTANT-CONS := (CONS CONSTANT-NODE CONSTANT-NODE)
+;;; CONSTANT-NODE := SINGLETON | CONSTANT-CONS
+(defun-cached (type-constant-cons-p :hash-function #'type-hash-value
+                                    :hash-bits 8
+                                    :values 2)
+              ((type eq))
+  (declare (type ctype type))
+  (and (cons-type-p type)
+       (let ((car-type (cons-type-car-type type))
+             (cdr-type (cons-type-cdr-type type)))
+         (multiple-value-bind (car-constant-p car-value)
+             (type-singleton-p car-type)
+           (unless car-constant-p
+             (setf (values car-constant-p car-value)
+                   (type-constant-cons-p car-type)))
+           (multiple-value-bind (cdr-constant-p cdr-value)
+               (type-singleton-p cdr-type)
+             (unless cdr-constant-p
+               (setf (values cdr-constant-p cdr-value)
+                     (type-constant-cons-p cdr-type)))
+             (if (and car-constant-p cdr-constant-p)
+                 (values t (cons car-value cdr-value))
+                 (values nil nil)))))))
+
 ;;; (VALUES-SPECIFIER-TYPE and SPECIFIER-TYPE moved from here to
 ;;; early-type.lisp by WHN ca. 19990201.)
 
diff --git a/src/compiler/array-tran.lisp b/src/compiler/array-tran.lisp
index d57af3886..a1586f495 100644
--- a/src/compiler/array-tran.lisp
+++ b/src/compiler/array-tran.lisp
@@ -304,13 +304,13 @@
                  ,(cond ((not element-type) t)
                         ((ctype-p element-type)
                          (type-specifier element-type))
-                        ((constant-lvar-p element-type)
+                        ((constant-lvar-p element-type :immutable t)
                          (let ((ctype (careful-specifier-type
-                                       (lvar-value element-type))))
+                                       (lvar-value element-type :immutable t))))
                            (cond
                              ((or (null ctype) (contains-unknown-type-p ctype)) '*)
                              (t (sb-xc:upgraded-array-element-type
-                                 (lvar-value element-type))))))
+                                 (lvar-value element-type :immutable t))))))
                         (t
                          '*))
                  ,(cond ((constant-lvar-p dims)
diff --git a/src/compiler/ir1opt.lisp b/src/compiler/ir1opt.lisp
index aada63bea..ba9b58903 100644
--- a/src/compiler/ir1opt.lisp
+++ b/src/compiler/ir1opt.lisp
@@ -20,8 +20,9 @@
 
 ;;; Return true for an LVAR whose sole use is a reference to a
 ;;; constant leaf.
-(defun constant-lvar-p (thing)
-  (declare (type (or lvar null) thing))
+(defun constant-lvar-p (thing &key immutable)
+  (declare (type (or lvar null) thing)
+           (type boolean immutable))
   (and (lvar-p thing)
        (let* ((type (lvar-type thing))
               (principal-lvar (principal-lvar thing))
@@ -35,8 +36,11 @@
                   ;; they expect LVAR-VALUE to be of a restricted type.
                   (or (not (lvar-reoptimize principal-lvar))
                       (ctypep (constant-value leaf) type)))
-             ;; check for EQL types and singleton numeric types
-             (values (type-singleton-p type))))))
+             ;; check for EQL types, singleton numeric types
+             (values (type-singleton-p type))
+             ;; check for CONS of singletons
+             (and immutable
+                  (values (type-constant-cons-p type)))))))
 
 ;;; Are all the uses constant?
 (defun constant-lvar-uses-p (thing)
@@ -59,9 +63,10 @@
                           (ctypep (constant-value leaf) type))))))))
 
 ;;; Return the constant value for an LVAR whose only use is a constant
-;;; node.
-(declaim (ftype (function (lvar) t) lvar-value))
-(defun lvar-value (lvar)
+;;; node. If IMMUTABLE is T, LVAR-VALUE is allowed to return a value
+;;; which is not EQ but EQUALP to the actual value.
+(declaim (ftype (function (lvar &key (:immutable boolean)) t) lvar-value))
+(defun lvar-value (lvar &key immutable)
   (let ((use  (principal-lvar-use lvar))
         (type (lvar-type lvar))
         leaf)
@@ -69,9 +74,12 @@
              (constant-p (setf leaf (ref-leaf use))))
         (constant-value leaf)
         (multiple-value-bind (constantp value) (type-singleton-p type)
-          (unless constantp
-            (error "~S used on non-constant LVAR ~S" 'lvar-value lvar))
-          value))))
+          (if constantp
+              value
+              (multiple-value-bind (constantp value) (type-constant-cons-p type)
+                (if (and immutable constantp)
+                    value
+                    (error "~S used on non-constant LVAR ~S" 'lvar-value lvar))))))))
 
 (defun lvar-uses-values (lvar)
   (let ((uses (principal-lvar-use lvar)))