(defun try-merge-numeric-ranges (union-ctype)
  (let* ((ctypes (union-ctype-types union-ctype))
         (result (copy-list ctypes)))
    (dolist (ctype ctypes)
      (when (and (numeric-ctype-p ctype)
                 (numeric-ctype-high ctype)
                 (listp (numeric-ctype-high ctype)))
        (let* ((bound (first (numeric-ctype-high ctype)))
               (class (or (numeric-ctype-class ctype) 'real))
               (bound-ctype (specifier-type `(,class ,bound ,bound))))
          (when (find-if (lambda (x) (csubtypep bound-ctype x)) ctypes)
            (push bound-ctype result)))))
    (specifier-type (type-specifier (make-union-ctype result)))))

CCL> *ctype*
#<UNION-CTYPE (OR (REAL * (-3.5D0)) (NOT INTEGER) (REAL (-3.5D0)))>

CCL> (try-merge-numeric-ranges *ctype*)
#<NAMED-CTYPE T>