Define a macro that eliminates this repetitive pattern:
(defdata either (left t) (right t))

Issue: Macro call that should be transformed by defdata

Macro definition:
(defmacro defdata (adt-name &body constructors)
  "Define a new ADT. ADT-name has the following grammar:

ADT-NAME := <symbol>
          | (<symbol> <options>*)

There is no difference between specifying it as a symbol or as a
singleton list. There are two possible options, specified as a
property list:

    * :MUTABLE {T, NIL} (default: NIL): Specifies whether the fields
      of the type are mutable, allowing the use of SET-DATA.

    * :INCLUDE <adt-type>: Specifies whether another defined ADT
      should be inherited.

Constructors is a list of clauses with the following grammar:

<clause> := <symbol>
          | (<symbol> <type-specifier>*)

Each clause defines a constructor for the ADT. Nullary constructors
will define constants and all other constructors will define
functions."
  ;; Do some extreme sanity checking.
  (assert
   (or
    ;; Must be a symbol, or...
    (symbolp adt-name)
    (and
     ;; a list that is...
     (listp adt-name)
     ;; non-empty
     (not (null adt-name))
     ;; whose first element is a symbol (the name of the adt)
     (symbolp (first adt-name))
     ;; and the rest is a property list
     (property-list-p (rest adt-name))))
   (adt-name)
   "ADT-NAME must either be a symbol, a singleton list with the ADT ~
      name as a symbol, or a list of two elements with the ADT name ~
      and :MUTABLE respectively. Given ~S."
   adt-name)
  (let ((valid-options (list ':mutable ':include)))
    (when (and (listp adt-name) (= (mod (length (rest adt-name)) 2) 0))
      (loop for opt in (rest adt-name) by #'cddr do
	   (when (not (member opt valid-options))
	     (error "Option ~A is not valid, valid options are member of ~A." opt valid-options)))))

  (let ((adt-name (ensure-car adt-name))
        (mutable? (and (listp adt-name)
                       (getf (rest adt-name) ':mutable)
                       t))
        (include (or (and (listp adt-name)
                          (getf (rest adt-name) ':include))
                     'algebraic-data-type))
        (object (gensym "OBJECT-"))
        (stream (gensym "STREAM-"))
        (depth (gensym "DEPTH-"))
        (env (gensym "ENVIRONMENT-"))
        (documentation
          (when (stringp (car constructors))
            (pop constructors))))

    ;; Sanity check that INCLUDE is a proper algebraic data type.
    (assert (algebraic-data-type-p include)
            ()
            "When defining the algebraic data type ~S, the :INCLUDE option ~
             was specified with ~S, which is not another algebraic data ~
             type."
            adt-name
            include)

    ;; Add constructors and their arity to the database.
    (flet ((constructor-and-arity (ctor)
             (if (listp ctor)
                 (list (first ctor) (length (rest ctor)))
                 (list ctor 0))))
      (set-constructors adt-name (append (get-constructors include)
                                         (mapcar #'constructor-and-arity constructors))))

    (flet ((make-printer (name &optional (nfields 0))
             "Make a printer function for the structs."
             `(lambda (,object ,stream ,depth)
                (declare (ignore ,depth)
                         (ignorable ,object))
                ;; We don't check *PRINT-READABLY* because these can
                ;; be readably printed always, provided the arguments
                ;; can be printed readably.
                ;;
                ;; However, we do respect a convenience option
                ;; *PRINT-ADT-READABLY* in case someone finds the
                ;; printing of the #. to be annoying.
                (when *print-adt-readably*
                  (write-string "#." ,stream))
                ,(when (plusp nfields)
                   `(write-char #\( ,stream))
                (prin1 ',name ,stream)
                ,@(when (plusp nfields)
                    (loop :for i :below nfields
                          :append (list
                                   `(write-char #\Space ,stream)
                                   `(prin1 (,(field name i) ,object)
                                           ,stream))))
                ,(when (plusp nfields)
                   `(write-char #\) ,stream)))))
      ;; Define everything.
      (let ((component-documentation
             ;; Force the adt-name symbol to print with a package
             ;; prefix
             (let ((*package* (find-package :keyword)))
               (format nil "A component of ADT ~S" adt-name))))
        `(eval-when (:compile-toplevel :load-toplevel :execute)
           ;; Define the data type.
           (defstruct (,adt-name (:constructor nil)
                                 (:copier nil)
                                 (:predicate nil)
                                 (:include ,include))
             ,@(unsplice documentation))

           ;; Define each of the field constructors.
           ,@(loop :for ctor :in (unwrap-singletons constructors)
                   :collect
                   (etypecase ctor
                     ;; Nullary constructor
                     (symbol `(progn
                                (eval-when (:compile-toplevel :load-toplevel :execute)
                                  (defstruct
                                      (,ctor
                                       (:include ,adt-name)
                                       (:constructor ,(internal ctor))
                                       (:copier nil)
                                       (:predicate nil)
                                       (:print-function ,(make-printer ctor)))
                                    ,component-documentation))
                                #+sbcl (declaim (sb-ext:freeze-type ,ctor))
                                (defmethod make-load-form ((,object ,ctor) &optional ,env)
                                  (make-load-form-saving-slots ,object
                                                               :slot-names nil
                                                               :environment ,env))
                                (define-constant ,ctor (,(internal ctor))
                                  ,component-documentation)
                                (fmakunbound ',(internal ctor))))

                     ;; N-ary constructors
                     (list (let* ((ctor-name (first ctor))
                                  (field-types (rest ctor))
                                  (field-names (gen-names (length field-types))))
                             `(progn
                                (defstruct (,ctor-name
                                            (:include ,adt-name)
                                            (:constructor ,ctor-name (,@field-names))
                                            (:conc-name ,ctor-name)
                                            (:copier nil)
                                            (:predicate nil)
                                            (:print-function
                                             ,(make-printer ctor-name
                                                            (length field-names))))
                                  ,component-documentation
                                  ,@(mapcar (lambda (name type)
                                              `(,name (error "Unspecified field.")
                                                      :type ,type
                                                      ,@(if mutable?
                                                            nil
                                                            '(:read-only t))))
                                     field-names
                                     field-types))
                                #+sbcl (declaim (sb-ext:freeze-type ,ctor-name))
                                (defmethod make-load-form ((,object ,ctor-name) &optional ,env)
                                  (make-load-form-saving-slots ,object
                                                               :slot-names ',field-names
                                                               :environment ,env)))))))
           ;; Return the type name
           ',adt-name)))))

Macroexpansion:
(eval-when (:compile-toplevel :load-toplevel :execute) (defstruct (either (:constructor nil) (:copier nil) (:predicate nil) (:include algebraic-data-type))) (progn (defstruct (left (:include either) (:constructor left (%0)) (:conc-name left) (:copier nil) (:predicate nil) (:print-function (lambda (#:object-137 #:stream-138 #:depth-139) (declare (ignore #:depth-139) (ignorable #:object-137)) (when *print-adt-readably* (write-string "#." #:stream-138)) (write-char #\LEFT_PARENTHESIS #:stream-138) (prin1 (quote left) #:stream-138) (write-char #\Space #:stream-138) (prin1 (left%0 #:object-137) #:stream-138) (write-char #\RIGHT_PARENTHESIS #:stream-138)))) #A((49) base-char . "A component of ADT CL-ALGEBRAIC-DATA-TYPE::EITHER") (%0 (error "Unspecified field.") :type t :read-only t)) (declaim (sb-ext:freeze-type left)) (defmethod make-load-form ((#:object-137 left) &optional #:environment-140) (make-load-form-saving-slots #:object-137 :slot-names (quote (%0)) :environment #:environment-140))) (progn (defstruct (right (:include either) (:constructor right (%0)) (:conc-name right) (:copier nil) (:predicate nil) (:print-function (lambda (#:object-137 #:stream-138 #:depth-139) (declare (ignore #:depth-139) (ignorable #:object-137)) (when *print-adt-readably* (write-string "#." #:stream-138)) (write-char #\LEFT_PARENTHESIS #:stream-138) (prin1 (quote right) #:stream-138) (write-char #\Space #:stream-138) (prin1 (right%0 #:object-137) #:stream-138) (write-char #\RIGHT_PARENTHESIS #:stream-138)))) #A((49) base-char . "A component of ADT CL-ALGEBRAIC-DATA-TYPE::EITHER") (%0 (error "Unspecified field.") :type t :read-only t)) (declaim (sb-ext:freeze-type right)) (defmethod make-load-form ((#:object-137 right) &optional #:environment-140) (make-load-form-saving-slots #:object-137 :slot-names (quote (%0)) :environment #:environment-140))) (quote either))