diff --git a/collects/racket/contract/private/arr-i.rkt b/collects/racket/contract/private/arr-i.rkt
index 7292efc2aa..7329480552 100644
--- a/collects/racket/contract/private/arr-i.rkt
+++ b/collects/racket/contract/private/arr-i.rkt
@@ -7,6 +7,7 @@
          "misc.rkt"
          "blame.rkt"
          syntax/location
+         racket/performance-hint
          (for-syntax racket/base
                      racket/stxparam-exptime
                      "arr-i-parse.rkt"
@@ -623,9 +624,10 @@
                   (λ args (apply arg-checker args)))
                  impersonator-prop:contracted ctc))))))))
 
-(define (un-dep ctc obj blame)
-  (let ([ctc (coerce-contract '->i ctc)])
-    (((contract-projection ctc) blame) obj)))
+(begin-encourage-inline
+  (define (un-dep ctc obj blame)
+    (let ([ctc (coerce-contract '->i ctc)])
+      (((contract-projection ctc) blame) obj))))
 
 (define-for-syntax (mk-used-indy-vars an-istx)
   (let ([vars (make-free-identifier-mapping)])
diff --git a/collects/racket/contract/private/arrow.rkt b/collects/racket/contract/private/arrow.rkt
index 5404adf463..901c8ba62c 100644
--- a/collects/racket/contract/private/arrow.rkt
+++ b/collects/racket/contract/private/arrow.rkt
@@ -569,13 +569,14 @@ v4 todo:
 
 (define-struct (chaperone-> base->) ()
   #:property prop:chaperone-contract
-  (build-chaperone-contract-property
-   #:projection (->-proj chaperone-procedure)
-   #:name ->-name
-   #:first-order ->-first-order
-   #:stronger ->-stronger?
-   #:generate ->-generate
-   #:exercise ->-exercise))
+  (parameterize ([skip-projection-wrapper? #t])
+    (build-chaperone-contract-property
+     #:projection (->-proj chaperone-procedure)
+     #:name ->-name
+     #:first-order ->-first-order
+     #:stronger ->-stronger?
+     #:generate ->-generate
+     #:exercise ->-exercise)))
 
 (define-struct (impersonator-> base->) ()
   #:property prop:contract
diff --git a/collects/racket/contract/private/base.rkt b/collects/racket/contract/private/base.rkt
index 98b3c348bd..855ba6a32d 100644
--- a/collects/racket/contract/private/base.rkt
+++ b/collects/racket/contract/private/base.rkt
@@ -47,7 +47,7 @@ improve method arity mismatch contract violation error messages?
     (check-source-location! 'contract loc)
     (let ([new-val
            (((contract-projection c)
-             (make-blame loc name (contract-name c) pos neg #t))
+             (make-blame loc name (λ () (contract-name c)) pos neg #t))
             v)])
       (if (and (not (parameter? new-val))  ;; when PR 11221 is fixed, remove this line
                (procedure? new-val)
diff --git a/collects/racket/contract/private/basic-opters.rkt b/collects/racket/contract/private/basic-opters.rkt
index 182c0b5300..a9e65589ec 100644
--- a/collects/racket/contract/private/basic-opters.rkt
+++ b/collects/racket/contract/private/basic-opters.rkt
@@ -18,12 +18,7 @@
                    (blame (opt/info-blame opt/info)))
        (syntax (if (pred val)
                    val
-                   (raise-blame-error
-                    blame
-                    val
-                    "expected: ~s, given: ~e"
-                    (contract-name ctc)
-                    val))))
+                   (raise-opt/pred-error blame val 'pred))))
      null
      null
      null
@@ -32,33 +27,24 @@
      null
      #t)))
 
+(define (raise-opt/pred-error blame val pred-name)
+  (raise-blame-error
+   blame
+   val
+   "expected ~a"
+   pred-name))
+
 ;;
 ;; built-in predicate opters
 ;;
-(define/opter (null? opt/i opt/info stx)
-  (syntax-case stx (null?)
-    [null? (opt/pred opt/info #'null?)]))
-(define/opter (boolean? opt/i opt/info stx)
-  (syntax-case stx (boolean?)
-    [boolean? (opt/pred opt/info #'boolean?)]))
-(define/opter (string? opt/i opt/info stx)
-  (syntax-case stx (string?)
-    [string? (opt/pred opt/info #'string?)]))
-(define/opter (integer? opt/i opt/info stx)
-  (syntax-case stx (integer?)
-    [integer? (opt/pred opt/info #'integer?)]))
-(define/opter (char? opt/i opt/info stx)
-  (syntax-case stx (char?)
-    [char? (opt/pred opt/info #'char?)]))
-(define/opter (number? opt/i opt/info stx)
-  (syntax-case stx (number?)
-    [number? (opt/pred opt/info #'number?)]))
-(define/opter (pair? opt/i opt/info stx)
-  (syntax-case stx (pair?)
-    [pair? (opt/pred opt/info #'pair?)]))
-(define/opter (not opt/i opt/info stx)
-  (syntax-case stx (not)
-    [not (opt/pred opt/info #'not)]))
+(define/opter (null? opt/i opt/info stx) (opt/pred opt/info #'null?))
+(define/opter (boolean? opt/i opt/info stx) (opt/pred opt/info #'boolean?))
+(define/opter (string? opt/i opt/info stx) (opt/pred opt/info #'string?))
+(define/opter (integer? opt/i opt/info stx) (opt/pred opt/info #'integer?))
+(define/opter (char? opt/i opt/info stx) (opt/pred opt/info #'char?))
+(define/opter (number? opt/i opt/info stx) (opt/pred opt/info #'number?))
+(define/opter (pair? opt/i opt/info stx) (opt/pred opt/info #'pair?))
+(define/opter (not opt/i opt/info stx) (opt/pred opt/info #'not))
 
 ;;
 ;; any/c
@@ -78,9 +64,7 @@
 ;;
 ;; false/c
 ;;
-(define/opter (false/c opt/i opt/info stx)
-  (syntax-case stx (false/c)
-    [false/c (opt/pred opt/info #'not)]))
+(define/opter (false/c opt/i opt/info stx) (opt/pred opt/info #'not))
 
 ;;
 ;; flat-contract helper
diff --git a/collects/racket/contract/private/blame.rkt b/collects/racket/contract/private/blame.rkt
index dd591287bd..65cbd6d540 100644
--- a/collects/racket/contract/private/blame.rkt
+++ b/collects/racket/contract/private/blame.rkt
@@ -1,5 +1,4 @@
 #lang racket/base
-
 (require syntax/srcloc racket/pretty setup/path-to-relative)
 
 (provide blame?
@@ -35,10 +34,12 @@
                (hash/recur (blame-original? b))))
 
 (define-struct blame
-  [source value contract positive negative original?]
+  [source value build-name positive negative original?]
   #:property prop:equal+hash
   (list blame=? blame-hash blame-hash))
 
+(define (blame-contract b) ((blame-build-name b)))
+
 (define (blame-swap b)
   (struct-copy
    blame b
diff --git a/collects/racket/contract/private/ds-helpers.rkt b/collects/racket/contract/private/ds-helpers.rkt
index cf138f1d73..fffcf39576 100644
--- a/collects/racket/contract/private/ds-helpers.rkt
+++ b/collects/racket/contract/private/ds-helpers.rkt
@@ -4,7 +4,8 @@
          build-clauses
          build-enforcer-clauses
          generate-arglists
-         (struct-out contract-struct-transformer))
+         (struct-out contract-struct-transformer)
+         defeat-inlining)
 
 (require racket/struct-info "opt-guts.rkt")
 (require (for-template racket/base))
@@ -47,19 +48,7 @@ which are then called when the contract's fields are explored
                                              "expected a field name and a contract together"
                                              stx
                                              clause)]))]))]
-         [all-ac-ids (generate-temporaries field-names)]
-         [defeat-inlining 
-           ;; makes the procedure confusing enough so that
-           ;; inlining doesn't consider it. this makes the 
-           ;; call to procedure-closure-contents-eq? work 
-           ;; properly
-           (λ (e)
-             (let loop ([n 30])
-               (if (zero? n)
-                   e
-                   #`(if (zero? (random 1))
-                         #,(loop (- n 1))
-                         (/ 1 0)))))])
+         [all-ac-ids (generate-temporaries field-names)])
     (let loop ([clauses (syntax->list clauses)]
                [ac-ids all-ac-ids]
                [prior-ac-ids '()]
@@ -112,6 +101,18 @@ which are then called when the contract's fields are explored
                   [_
                    (raise-syntax-error name "expected name/identifier binding" stx clause)]))]))]))))
 
+;; makes the procedure confusing enough so that
+;; inlining doesn't consider it. this makes the 
+;; call to procedure-closure-contents-eq? work 
+;; properly
+(define (defeat-inlining e)
+  (let loop ([n 30])
+    (if (zero? n)
+        e
+        #`(if (zero? (random 1))
+              #,(loop (- n 1))
+              (/ 1 0)))))
+
 (define (build-clauses/where name stx clauses field-names maker-args)
   (with-syntax ([(field-names ...) field-names])
     (let loop ([clauses clauses]
@@ -143,7 +144,9 @@ which are then called when the contract's fields are explored
     (syntax-case stx ()
       [(f arg ...)
        ;; we need to override the default optimization of recursive calls to use our helper
-       (and (opt/info-recf opt/info) (free-identifier=? (opt/info-recf opt/info) #'f))
+       (and (identifier? #'f) 
+            (opt/info-recf opt/info)
+            (free-identifier=? (opt/info-recf opt/info) #'f))
        (values
         #`(f #,id arg ...)
         null
diff --git a/collects/racket/contract/private/ds.rkt b/collects/racket/contract/private/ds.rkt
index f02d69efe4..0019dfe343 100644
--- a/collects/racket/contract/private/ds.rkt
+++ b/collects/racket/contract/private/ds.rkt
@@ -22,7 +22,7 @@ it around flattened out.
          "blame.rkt"
          "opt.rkt"
          "misc.rkt")
-(require (for-syntax scheme/base)
+(require (for-syntax racket/base)
          (for-syntax "ds-helpers.rkt")
          (for-syntax "helpers.rkt")
          (for-syntax "opt-guts.rkt"))
@@ -367,8 +367,7 @@ it around flattened out.
                             [enforcer-id enforcer-id-var]
                             [helper-id helper-id-var]
                             [((free-var free-var-val) (... ...))
-                             (make-free-vars (append (opt/info-free-vars opt/info)) #'freev)]
-                            [(saved-lifts (... ...)) (lifts-to-save lifts)])
+                             (make-free-vars (append (opt/info-free-vars opt/info)) #'freev)])
                 (values
                  #`(λ (stct f-x ...)
                      (let ((free-var free-var-val) (... ...))
diff --git a/collects/racket/contract/private/legacy.rkt b/collects/racket/contract/private/legacy.rkt
index 3fbb6ab25e..77ea443dff 100644
--- a/collects/racket/contract/private/legacy.rkt
+++ b/collects/racket/contract/private/legacy.rkt
@@ -10,7 +10,7 @@
   (apply raise-blame-error
          (make-blame (unpack-source src)
                      (unpack-name src)
-                     name
+                     (λ () name)
                      (unpack-blame pos)
                      "<<unknown party>>"
                      #t)
@@ -47,7 +47,7 @@
     (lambda (pos neg src name [original? #t])
       (proj (make-blame (unpack-source src)
                         (unpack-name src)
-                        name
+                        (λ () name)
                         (unpack-blame (if original? pos neg))
                         (unpack-blame (if original? neg pos))
                         original?)))))
diff --git a/collects/racket/contract/private/misc.rkt b/collects/racket/contract/private/misc.rkt
index 9fe5a5d257..641d2ba58c 100644
--- a/collects/racket/contract/private/misc.rkt
+++ b/collects/racket/contract/private/misc.rkt
@@ -178,11 +178,12 @@
 
 (define-struct (chaperone-single-or/c single-or/c) ()
   #:property prop:chaperone-contract
-  (build-chaperone-contract-property
-   #:projection single-or/c-projection
-   #:name single-or/c-name
-   #:first-order single-or/c-first-order
-   #:stronger single-or/c-stronger?))
+  (parameterize ([skip-projection-wrapper? #t])
+    (build-chaperone-contract-property
+     #:projection single-or/c-projection
+     #:name single-or/c-name
+     #:first-order single-or/c-first-order
+     #:stronger single-or/c-stronger?)))
 
 (define-struct (impersonator-single-or/c single-or/c) ()
   #:property prop:contract
@@ -264,11 +265,12 @@
 
 (define-struct (chaperone-multi-or/c multi-or/c) ()
   #:property prop:chaperone-contract
-  (build-chaperone-contract-property
-   #:projection multi-or/c-proj
-   #:name multi-or/c-name
-   #:first-order multi-or/c-first-order
-   #:stronger multi-or/c-stronger?))
+  (parameterize ([skip-projection-wrapper? #t])
+    (build-chaperone-contract-property
+     #:projection multi-or/c-proj
+     #:name multi-or/c-name
+     #:first-order multi-or/c-first-order
+     #:stronger multi-or/c-stronger?)))
 
 (define-struct (impersonator-multi-or/c multi-or/c) ()
   #:property prop:contract
@@ -376,11 +378,12 @@
    #:stronger and-stronger?))
 (define-struct (chaperone-and/c base-and/c) ()
   #:property prop:chaperone-contract
-  (build-chaperone-contract-property
-   #:projection and-proj
-   #:name and-name
-   #:first-order and-first-order
-   #:stronger and-stronger?))
+  (parameterize ([skip-projection-wrapper? #t])
+    (build-chaperone-contract-property
+     #:projection and-proj
+     #:name and-name
+     #:first-order and-first-order
+     #:stronger and-stronger?)))
 (define-struct (impersonator-and/c base-and/c) ()
   #:property prop:contract
   (build-contract-property
@@ -763,10 +766,11 @@
 
 (struct chaperone-list/c generic-list/c ()
   #:property prop:chaperone-contract
-  (build-chaperone-contract-property
-   #:name list/c-name-proc
-   #:first-order list/c-first-order
-   #:projection list/c-chaperone/other-projection))
+  (parameterize ([skip-projection-wrapper? #t])
+    (build-chaperone-contract-property
+     #:name list/c-name-proc
+     #:first-order list/c-first-order
+     #:projection list/c-chaperone/other-projection)))
 
 (struct higher-order-list/c generic-list/c ()
   #:property prop:contract
diff --git a/collects/racket/contract/private/opt-guts.rkt b/collects/racket/contract/private/opt-guts.rkt
index c7f0949471..d899dd4a25 100644
--- a/collects/racket/contract/private/opt-guts.rkt
+++ b/collects/racket/contract/private/opt-guts.rkt
@@ -131,14 +131,21 @@
 ;; the initial lifts
 (define empty-lifts '())
 
-(define (bind-lifts lifts stx) (do-bind-lifts lifts stx #'let*))
-(define (bind-superlifts lifts stx) (do-bind-lifts lifts stx #'letrec))
+(define (bind-lifts lifts stx) (do-bind-lifts lifts stx #'let*-values))
+(define (bind-superlifts lifts stx) (do-bind-lifts lifts stx #'letrec-values))
 
 (define (do-bind-lifts lifts stx binding-form)
   (if (null? lifts)
       stx
       (with-syntax ([((lifts-x . lift-e) ...) lifts])
-        (with-syntax ([(lifts-x ...) (map (λ (x) (if (identifier? x) x (car (generate-temporaries '(junk)))))
+        (with-syntax ([(lifts-x ...) (map (λ (x) (cond
+                                                   [(identifier? x) (list x)]
+                                                   [(let ([lst (syntax->list x)])
+                                                      (and lst
+                                                           (andmap identifier? lst)))
+                                                    x]
+                                                   [else
+                                                    (generate-temporaries '(junk))]))
                                           (syntax->list (syntax (lifts-x ...))))]
                       [binding-form binding-form])
           #`(binding-form ([lifts-x lift-e] ...)
diff --git a/collects/racket/contract/private/opt.rkt b/collects/racket/contract/private/opt.rkt
index 5463b58264..446d052d05 100644
--- a/collects/racket/contract/private/opt.rkt
+++ b/collects/racket/contract/private/opt.rkt
@@ -1,6 +1,7 @@
 #lang racket/base
 (require "prop.rkt"
          "misc.rkt"
+         "blame.rkt"
          racket/stxparam)
 (require (for-syntax racket/base)
          (for-syntax "opt-guts.rkt")
@@ -10,18 +11,23 @@
          opt/direct
          begin-lifted)
 
-;; define/opter : id -> syntax
+;; (define/opter (<contract-combinator> opt/i opt/info stx) body)
 ;;
-;; Takes an expression which is to be expected of the following signature: 
+;; An opter is to a function with the following signature: 
 ;;
-;; opter : id id syntax list-of-ids ->
-;;         syntax syntax-list syntax-list syntax-list (union syntax #f) (union syntax #f) syntax
-;;         
+;; opter : (syntax opt/info -> <opter-results>) opt/info list-of-ids ->
+;;         (values syntax syntax-list syntax-list
+;;                 syntax-list (union syntax #f) (union syntax #f) syntax)
 ;;
-;; It takes in an identifier for pos, neg, and the original syntax. An identifier
-;; that can be used to call the opt/i function is also implicitly passed into
-;; every opter. A list of free-variables is implicitly passed if the calling context
-;; was define/osc otherwise it is null.
+;; The first argument can be used to recursively process sub-contracts
+;; It returns what an opter returns and its results should be accumulated
+;; into the opter's results.
+;;
+;; The opt/info struct has a number of identifiers that get used to build
+;; contracts; see opt-guts.rkt for the selectors.
+;;
+;; The last argument is a list of free-variables if the calling context
+;; was define/opt otherwise it is null.
 ;;
 ;; Every opter needs to return:
 ;;  - the optimized syntax
@@ -40,6 +46,7 @@
 ;;    else the symbol of the lifted variable
 ;;    This is used for contracts with subcontracts (like cons) doing checks.
 ;;  - a list of stronger-ribs
+;;  - a boolean indicating if this contract is a chaperone contract
 (define-syntax (define/opter stx)
   (syntax-case stx ()
     [(_ (for opt/i opt/info stx) expr ...)
@@ -82,6 +89,55 @@
         (with-syntax (((stronger ...) strongers))
           (syntax (and stronger ...))))))
 
+(define-for-syntax (coerecable-constant? konst)
+  (syntax-case konst (quote)
+    ['x
+     (identifier? #'x)
+     #t]
+    [other
+     (let ([o (syntax-e #'other)])
+       (or (boolean? o)
+           (char? o)
+           (null? o)
+           (string? o)
+           (bytes? o)
+           (number? o)))]))
+
+(define-for-syntax (opt-constant-contract konst opt/info)
+  (define v (opt/info-val opt/info))
+  (define-values (predicate word)
+    (cond
+      [(and (pair? konst) (eq? (car konst) 'quote))
+       (values #`(eq? #,konst #,v)
+               "eq?")]
+      [(or (boolean? konst) (char? konst) (null? konst))
+       (values #`(eq? #,konst #,v)
+               "eq?")]
+      [(or (string? konst) (bytes? konst))
+       (values #`(equal? #,konst #,v)
+               "equal?")]
+      [(number? konst)
+       (values #`(and (number? #,v) (= #,konst #,v))
+               "=")]))
+  (values
+   #`(if #,predicate
+         #,v
+         (opt-constant-contract-failure #,(opt/info-blame opt/info) #,v #,word #,konst))
+   null
+   null
+   null
+   predicate
+   #f
+   null
+   #t))
+
+(define (opt-constant-contract-failure blame val compare should-be)
+  (raise-blame-error blame val "expected a value ~a to ~e" compare should-be))
+
+(begin-for-syntax
+  (define-struct define-opt/recursive-fn (transformer internal-fn)
+    #:property prop:procedure 0))
+
 ;; opt/i : id opt/info syntax ->
 ;;         syntax syntax-list syntax-list (union syntax #f) (union syntax #f)
 (define-for-syntax (opt/i opt/info stx)
@@ -95,11 +151,13 @@
      ((opter #'argless-ctc) opt/i opt/info stx)]
     [(f arg ...)
      (and (identifier? #'f) 
-          (syntax-parameter-value #'define/opt-recursive-fn)
-          (free-identifier=? (syntax-parameter-value #'define/opt-recursive-fn)
-                             #'f))
+          (define-opt/recursive-fn? (syntax-local-value #'f (λ () #f))))
      (values
-      #`(#,(syntax-parameter-value #'define/opt-recursive-fn) #,(opt/info-val opt/info) arg ...)
+      #`(#,(define-opt/recursive-fn-internal-fn (syntax-local-value #'f))
+         #,(opt/info-contract opt/info)
+         #,(opt/info-blame opt/info)
+         #,(opt/info-val opt/info)
+         arg ...)
       null
       null
       null
@@ -107,7 +165,16 @@
       #f
       null
       #t)]
+    [konst
+     (coerecable-constant? #'konst)
+     (opt-constant-contract (syntax->datum #'konst) opt/info)]
     [else
+     (log-info (format "warning in ~a:~a: opt/c doesn't know the contract ~s" 
+                       (syntax-source stx)
+                       (if (syntax-line stx)
+                           (format "~a:~a" (syntax-line stx) (syntax-column stx))
+                           (format ":~a" (syntax-position stx)))
+                       (syntax->datum stx)))
      (opt/unknown opt/i opt/info stx)]))
 
 ;; top-level-unknown? : syntax -> boolean
@@ -120,11 +187,12 @@
     [argless-ctc
      (and (identifier? #'argless-ctc) (opter #'argless-ctc))
      #f]
+    [konst
+     (coerecable-constant? #'konst)
+     #f]
     [(f arg ...)
      (and (identifier? #'f) 
-          (syntax-parameter-value #'define/opt-recursive-fn)
-          (free-identifier=? (syntax-parameter-value #'define/opt-recursive-fn)
-                             #'f))
+          (define-opt/recursive-fn? (syntax-local-value #'f (λ () #f))))
      #f]
     [else
      #t]))
@@ -135,16 +203,12 @@
 ;; on things such as closure allocation time.
 (define-syntax (opt/c stx)  
   (syntax-case stx ()
-    [(_ e) 
-     (if (top-level-unknown? #'e)
-         #'e
-         #'(opt/c e ()))]
-    [(_ e (opt-recursive-args ...))
+    [(_ e)
      (let*-values ([(info) (make-opt/info #'ctc
                                           #'val
                                           #'blame
                                           #f
-                                          (syntax->list #'(opt-recursive-args ...))
+                                          '()
                                           #f
                                           #f
                                           #'this
@@ -158,18 +222,9 @@
            #`(make-opt-contract
               (λ (ctc)
                 (λ (blame)
-                  #,(if (syntax-parameter-value #'define/opt-recursive-fn)
-                        (with-syntax ([f (syntax-parameter-value #'define/opt-recursive-fn)])
-                          (bind-superlifts
-                           (cons
-                            (cons (syntax-parameter-value #'define/opt-recursive-fn)
-                                  #'(λ (val opt-recursive-args ...) next))
-                            partials)
-                           #'(λ (val) 
-                               (f val opt-recursive-args ...))))
-                        (bind-superlifts
-                         partials
-                         #`(λ (val) next)))))
+                  #,(bind-superlifts
+                     partials
+                     #`(λ (val) next))))
               (λ () e)
               (λ (this that) #f)
               (vector)
@@ -209,14 +264,64 @@
     [(_ expr)
      (syntax-local-lift-expression #'expr)]))
 
-(define-syntax-parameter define/opt-recursive-fn #f)
-
 (define-syntax (define-opt/c stx)
   (syntax-case stx ()
-    [(_ (id args ...) body)
-     #'(define (id args ...)
-         (syntax-parameterize ([define/opt-recursive-fn #'id])
-                              (opt/c body (args ...))))]))
+    [(_ (id args ...) e)
+     (with-syntax ([(f1 f2)
+                    (generate-temporaries (list (format "~a-f1" (syntax-e #'id))
+                                                (format "~a-f2" (syntax-e #'id))))])
+       #`(begin
+           (define-syntax id
+             (define-opt/recursive-fn
+               (λ (stx)
+                 (syntax-case stx ()
+                   [f
+                    (identifier? #'f)
+                    #'f1]
+                   [(f . call-args)
+                    (with-syntax ([app (datum->syntax stx '#%app)])
+                      #'(app f1 . call-args))]))
+               #'f2))
+           (define-values (f1 f2) (opt/c-helper f1 f2 (id args ...) e))))]))
+
+(define-syntax (opt/c-helper stx)
+  (syntax-case stx ()
+    [(_ f1 f2 (id args ...) e)
+     (let*-values ([(info) (make-opt/info #'ctc
+                                          #'val
+                                          #'blame
+                                          #f
+                                          (syntax->list #'(args ...))
+                                          #f
+                                          #f
+                                          #'this
+                                          #'that)]
+                   [(next lifts superlifts partials _ __ stronger-ribs chaperone?) (opt/i info #'e)])
+       (with-syntax ([next next])
+         #`(let ()
+             (define (f2 ctc blame val args ...)
+               #,(bind-superlifts
+                  superlifts
+                  (bind-lifts
+                   lifts
+                   (bind-superlifts
+                    partials
+                    #'next))))
+             (define (f1 args ...)
+               #,(bind-superlifts
+                  superlifts
+                  (bind-lifts
+                   lifts
+                   #`(make-opt-contract
+                      (λ (ctc)
+                        (λ (blame)
+                          (λ (val) 
+                            (f2 ctc blame val args ...))))
+                      (λ () e)
+                      (λ (this that) #f)
+                      (vector)
+                      (begin-lifted (box #f))))))
+             (values f1 f2))))]))
 
 ;; optimized contracts
 ;;
diff --git a/collects/racket/contract/private/opters.rkt b/collects/racket/contract/private/opters.rkt
index cfb735dbcd..2bf37213a6 100644
--- a/collects/racket/contract/private/opters.rkt
+++ b/collects/racket/contract/private/opters.rkt
@@ -6,6 +6,7 @@
          "blame.rkt"
          "misc.rkt"
          "arrow.rkt"
+         "struct.rkt"
          (for-syntax racket/base
                      syntax/stx
                      "opt-guts.rkt"))
@@ -106,7 +107,8 @@
                                         val
                                         "none of the branches of the or/c matched"))))]
              [(= (length hos) 1)
-              (with-syntax ((ho-ctc ho-ctc))
+              (with-syntax ([ho-ctc ho-ctc]
+                            [val (opt/info-val opt/info)])
                 (syntax
                  (if next-ps val ho-ctc)))]
              ;; FIXME something's not right with this case.
@@ -153,12 +155,8 @@
              (values
               (syntax (if (and (number? val) (<= n val m)) 
                           val
-                          (raise-blame-error
-                           blame
-                           val
-                           "expected: ~s, given: ~e"
-                           (contract-name ctc)
-                           val)))
+                          (raise-opt-between/c-error
+                           blame val n m)))
               lifts3
               null
               null
@@ -178,6 +176,14 @@
                          (syntax (<= this that))))))
               #t)))))]))
 
+(define (raise-opt-between/c-error blame val lo hi)
+  (raise-blame-error
+   blame
+   val
+   "expected a number between ~a and ~a, given: ~e"
+   lo hi
+   val))
+
 (define-for-syntax (single-comparison-opter opt/info stx check-arg comparison arg)
   (with-syntax ([comparison comparison])
     (let*-values ([(lift-low lifts2) (lift/binding arg 'single-comparison-val empty-lifts)])
@@ -192,12 +198,7 @@
              (syntax 
               (if (and (real? val) (comparison val m)) 
                   val
-                  (raise-blame-error
-                   blame
-                   val
-                   "expected: ~s, given: ~e"
-                   (contract-name ctc)
-                   val)))
+                  (raise-opt-single-comparison-opter-error blame val comparison m)))
              lifts3
              null
              null
@@ -211,6 +212,26 @@
                         (syntax (comparison this that))))))
              #t)))))))
 
+(define (raise-opt-single-comparison-opter-error blame val comparison m)
+  (raise-blame-error
+   blame
+   val
+   "expected a number ~a ~a, given: ~e"
+   (object-name comparison) m
+   val))
+
+
+(define/opter (=/c opt/i opt/info stx)
+  (syntax-case stx (=/c)
+    [(=/c x)
+     (single-comparison-opter 
+      opt/info
+      stx
+      (λ (m) (with-syntax ([m m])
+               #'(check-unary-between/c '=/c m)))
+      #'=
+      #'x)]))
+
 (define/opter (>=/c opt/i opt/info stx)
   (syntax-case stx (>=/c)
     [(>=/c low)
diff --git a/collects/racket/contract/private/prop.rkt b/collects/racket/contract/private/prop.rkt
index 2f4875706b..48af9fecc0 100644
--- a/collects/racket/contract/private/prop.rkt
+++ b/collects/racket/contract/private/prop.rkt
@@ -29,7 +29,9 @@
 
          make-contract
          make-chaperone-contract
-         make-flat-contract)
+         make-flat-contract
+         
+         skip-projection-wrapper?)
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;;
@@ -167,6 +169,8 @@
 ;;
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
+(define skip-projection-wrapper? (make-parameter #f))
+
 (define ((build-property mk default-name projection-wrapper)
          #:name [get-name #f]
          #:first-order [get-first-order #f]
@@ -179,7 +183,9 @@
          [get-first-order (or get-first-order get-any?)]
          [get-projection
           (cond
-            [get-projection (projection-wrapper get-projection)]
+            [get-projection (if (skip-projection-wrapper?)
+                                get-projection
+                                (projection-wrapper get-projection))]
             [else (get-first-order-projection
                    get-name get-first-order)])]
          [stronger (or stronger weakest)])
@@ -299,4 +305,3 @@
 
 (define make-flat-contract
   (build-contract make-make-flat-contract 'anonymous-flat-contract))
-
diff --git a/collects/racket/contract/private/struct.rkt b/collects/racket/contract/private/struct.rkt
index 119ae193f3..a20f3546c9 100644
--- a/collects/racket/contract/private/struct.rkt
+++ b/collects/racket/contract/private/struct.rkt
@@ -2,14 +2,19 @@
 
 (require (for-syntax racket/base
                      racket/list
-                     racket/struct-info)
+                     racket/struct-info
+                     "opt-guts.rkt"
+                     (only-in "ds-helpers.rkt" defeat-inlining))
+         syntax/location
          racket/list
          "guts.rkt"
          "blame.rkt"
          "prop.rkt"
-         "misc.rkt")
+         "misc.rkt"
+         "opt.rkt")
 
-(provide struct/c)
+(provide struct/c
+         (rename-out [-struct/dc struct/dc]))
 
 (define-syntax (struct/c stx)
   (syntax-case stx ()
@@ -95,32 +100,37 @@
             (for ([p (in-list flat-imm-pos-projs)]
                   [ref (in-list flat-imm-refs)])
               (p (ref val)))
+            
             ;; While gathering up the selectors and the appropriate projections,
             ;; we go ahead and apply the projection to check the first order properties.
-            (let ([combined-imm-refs 
-                   (for/list ([p (in-list chap-imm-pos-projs)]
-                              [ref (in-list chap-imm-refs)])
-                     (p (ref val))
-                     (list ref (λ (s v) (p v))))]
-                  [combined-mut-refs
-                   (for/list ([p (in-list mut-pos-projs)]
-                              [ref (in-list mut-refs)])
-                     (p (ref val))
-                     (list ref (λ (s v) (p v))))]
-                  [combined-mut-sets
-                   (for/list ([p (in-list mut-neg-projs)]
-                              [set (in-list mut-sets)])
-                     (list set (λ (s v) (p v))))])
-              (apply chaperone-struct val
-                     (flatten (list combined-imm-refs combined-mut-refs combined-mut-sets
-                                    impersonator-prop:contracted ctc))))))))))
+            (let ([chaperone-args (list impersonator-prop:contracted ctc)])
+              
+              ;; combined-imm-refs
+              (for ([p (in-list chap-imm-pos-projs)]
+                    [ref (in-list chap-imm-refs)])
+                (p (ref val))
+                (set! chaperone-args (list* ref (λ (s v) (p v)) chaperone-args)))
+              
+              ;; combined-mut-refs
+              (for ([p (in-list mut-pos-projs)]
+                    [ref (in-list mut-refs)])
+                (p (ref val))
+                (set! chaperone-args (list* ref (λ (s v) (p v)) chaperone-args)))
+              
+              ;; combined-mut-sets
+              (for ([p (in-list mut-neg-projs)]
+                    [set (in-list mut-sets)])
+                (set! chaperone-args (list* set (λ (s v) (p v)) chaperone-args)))
+              
+              (apply chaperone-struct val chaperone-args))))))))
 
 (define-struct (chaperone-struct/c base-struct/c) ()
   #:property prop:chaperone-contract
-  (build-chaperone-contract-property
-   #:name struct/c-name
-   #:first-order struct/c-first-order
-   #:projection chaperone-struct/c-proj))
+  (parameterize ([skip-projection-wrapper? #t])
+    (build-chaperone-contract-property
+     #:name struct/c-name
+     #:first-order struct/c-first-order
+     #:projection chaperone-struct/c-proj)))
 
 (define (impersonator-struct/c-proj ctc)
   (let-values ([(flat-imms chap-imms)
@@ -234,3 +244,359 @@
      (make-chaperone-struct/c struct-name predicate immutables mutables)]
     [else
      (make-impersonator-struct/c struct-name predicate immutables mutables)]))
+
+(define unique (box #f))
+(define (un-dep ctc obj blame immutable-field)
+  (let ([ctc (coerce-contract 'struct/dc ctc)])
+    (when immutable-field
+      (check-chaperone-contract immutable-field ctc))
+    (((contract-projection ctc) blame) obj)))
+
+(define (struct/dc-name ctc)
+  'struct/dc)
+(define (struct/dc-first-order ctc)
+  (struct/dc-pred ctc))
+
+(define (struct/dc-proj ctc)
+  (define pred? (struct/dc-pred ctc))
+  (define mk-proj ((struct/dc-apply-proj ctc) ctc))
+  (λ (blame)
+    (define proj (mk-proj blame))
+    (λ (v)
+      (cond
+        [(and (struct/dc-imp-prop-pred? v)
+              (contract-stronger? (struct/dc-imp-prop-get v) ctc))
+         v]
+        [else
+         (unless (pred? v)
+           (raise-blame-error blame v "expected a ~a"
+                              (struct/dc-struct-name ctc)))
+         (proj v)]))))
+
+(define (struct/dc-stronger? this that)
+  (and (struct/dc? that)
+       (eq? (struct/dc-pred this)
+            (struct/dc-pred that))
+       (let loop ([this-procs/ctcs (struct/dc-procs/ctcs this)]
+                  [that-procs/ctcs (struct/dc-procs/ctcs that)])
+         (cond
+           [(and (null? this-procs/ctcs) (null? that-procs/ctcs)) #t]
+           [(and (pair? this-procs/ctcs) (pair? that-procs/ctcs))
+            (define fst-this (car this-procs/ctcs))
+            (define fst-that (car that-procs/ctcs))
+            (cond
+              [(and (contract-struct? fst-this) (contract-struct? fst-that))
+               (and (contract-stronger? fst-this fst-that)
+                    (loop (cdr this-procs/ctcs) (cdr that-procs/ctcs)))]
+              [(and (procedure? fst-this) (procedure? fst-that))
+               (and (procedure-closure-contents-eq? fst-this fst-that)
+                    (loop (cdr this-procs/ctcs) (cdr that-procs/ctcs)))]
+              [else #f])]
+           [else #f]))))
+         
+(define-struct struct/dc (apply-proj procs/ctcs pred struct-name here)
+  #:property prop:chaperone-contract
+  (parameterize ([skip-projection-wrapper? #t])
+    (build-chaperone-contract-property
+     #:name struct/dc-name
+     #:first-order struct/dc-first-order
+     #:projection struct/dc-proj
+     #:stronger struct/dc-stronger?)))
+
+(define-for-syntax (get-struct-info id stx)
+  (define inf (syntax-local-value id (λ () #f)))
+  (unless (struct-info? inf)
+    (raise-syntax-error 'struct/dc "expected a struct" stx id))
+  (define the-info (extract-struct-info inf))
+  (unless (list-ref the-info 2)
+    (raise-syntax-error 'struct/dc 
+                        "expected a struct with a known predicate"
+                        stx id))
+  the-info)
+      
+(define-values (struct/dc-imp-prop-desc
+                struct/dc-imp-prop-pred?
+                struct/dc-imp-prop-get)
+  (make-impersonator-property 'struct/dc))
+
+
+(define-for-syntax (clause->chap-proc struct-id info stx clause-stx)
+  (define sel-id (syntax-case clause-stx ()
+                   [(sel-id . rest) #'sel-id]))
+  (define (add-prefix id)
+    (datum->syntax id
+                   (string->symbol (format "~a-~a" 
+                                           (syntax-e sel-id)
+                                           (syntax-e id)))))
+  (define immutable-field
+    (for/or ([mutator (in-list (list-ref info 4))]
+             [selector (in-list (list-ref info 3))])
+      (cond
+        [(and (not mutator) (not selector))
+         ;; end, with some hidden info
+         ;; just assume not immutable
+         #f]
+        [else
+         (and (not mutator)
+              (let ([id (id->sel-id struct-id sel-id)])
+                (and (free-identifier=? id selector)
+                     id)))])))
+  (define (add-immutable-check ctc-id stx)
+    (if immutable-field
+        (list stx
+              #`(check-chaperone-contract '#,immutable-field #,ctc-id))
+        (list stx)))
+
+  (syntax-case clause-stx ()
+    ;; with caching
+    [(sel-id #:lazy (id ...) exp)
+     (with-syntax ([(sel-id ...) (map (λ (x) (id->sel-id struct-id x)) (syntax->list #'(id ...)))])
+       (with-syntax ([dep-proc (add-prefix #'dep-proc)])
+         #`(((define dep-proc (λ (id ...) #,(defeat-inlining #'exp))))
+            (begin)
+            (begin)
+            (begin)
+            (let ([cached unique])
+              (λ (strct fld)
+                (if (eq? cached unique)
+                    (begin
+                      (set! cached (un-dep (dep-proc (sel-id strct) ...) fld blame '#,immutable-field))
+                      cached)
+                    cached))))))]
+    [(sel-id (id ...) exp)
+     (with-syntax ([(sel-proc-id ...) (map (λ (x) (id->sel-id struct-id x)) (syntax->list #'(id ...)))])
+       (with-syntax ([dep-proc (add-prefix #'dep-proc)])
+         #`(((define dep-proc (λ (id ...) #,(defeat-inlining #'exp))))
+            (begin)
+            (begin)
+            (un-dep (dep-proc (sel-proc-id v) ...) (#,(id->sel-id struct-id #'sel-id) v) blame '#,immutable-field)
+            (λ (strct fld)
+              (un-dep (dep-proc (sel-proc-id strct) ...) fld blame '#,immutable-field)))))]
+    [(sel-id #:lazy exp)
+     (with-syntax ([ctc (add-prefix #'ctc)]
+                   [blame-to-proj (add-prefix #'blame-to-proj)]
+                   [proj (add-prefix #'proj)])
+       #`(#,(add-immutable-check #'ctc #'(define ctc (coerce-contract 'struct/dc exp)))
+          (define blame-to-proj (contract-struct-projection ctc))
+          (define proj (blame-to-proj blame))
+          (begin)
+          (let ([cached unique])
+            (λ (strct fld)
+              (if (eq? cached unique)
+                  (begin
+                    (set! cached (proj fld))
+                    cached)
+                  cached)))))]
+    [(sel-id exp)
+     (with-syntax ([ctc (add-prefix #'ctc)]
+                   [blame-to-proj (add-prefix #'blame-to-proj)]
+                   [proj (add-prefix #'proj)])
+       #`(#,(add-immutable-check #'ctc #'(define ctc (coerce-contract 'struct/dc exp)))
+          (define blame-to-proj (contract-struct-projection ctc))
+          (define proj (blame-to-proj blame))
+          (proj (#,(id->sel-id struct-id #'sel-id) v))
+          (if (flat-contract? ctc)
+              (λ (strct fld) fld)
+              (λ (strct fld) (proj fld)))))]
+    [_ (raise-syntax-error #f "malformed clause" stx clause-stx)]))
+
+(define (check-chaperone-contract immutable-field ctc)
+  (unless (chaperone-contract? ctc)
+    (error 'struct/dc "expected a chaperone contract for the immutable field ~a, got ~e" 
+           immutable-field
+           ctc)))
+
+(define-for-syntax (id->sel-id struct-id id) 
+  (datum->syntax
+   id
+   (string->symbol
+    (format "~a-~a" 
+            (syntax-e struct-id)
+            (syntax-e id)))))
+
+(define-syntax (-struct/dc stx)
+  (syntax-case stx ()
+    [(_ struct-id clause ...)
+     (let ()
+       (define info (get-struct-info #'struct-id stx))
+       (with-syntax ([(((before-ctc-bound ...) after-ctc-bound after-blame-bound first-order-check chap-proc) ...)
+                      (for/list ([clause (in-list (syntax->list #'(clause ...)))])
+                        (clause->chap-proc #'struct-id info stx clause))])
+         (with-syntax ([(id ...) (syntax-case #'((before-ctc-bound ...) ...) ()
+                                   [(((define id exp) . whatever) ...) #'(id ...)])]
+                       [(selectors+chap-procs ...)
+                        (apply
+                         append
+                         (for/list ([clause (in-list (syntax->list #'(clause ...)))]
+                                    [chap-proc (in-list (syntax->list #'(chap-proc ...)))])
+                           (list (id->sel-id
+                                  #'struct-id
+                                  (syntax-case clause ()
+                                    [(x . rest) #'x]))
+                                 chap-proc)))])
+           #`(let ()
+               before-ctc-bound ... ...
+               (letrec ([me
+                         (make-struct/dc
+                          (λ (ctc)
+                            after-ctc-bound ...
+                            (λ (blame)
+                              after-blame-bound ...
+                              (λ (v)
+                                first-order-check ...
+                                (chaperone-struct
+                                 v
+                                 selectors+chap-procs ...
+                                 struct/dc-imp-prop-desc
+                                 me))))
+                          (list id ...)
+                          #,(list-ref info 2)
+                          'struct-id
+                          (quote-module-name))])
+                 me)))))]))
+
+(define/opter (-struct/dc opt/i opt/info stx)
+  (syntax-case stx ()
+    [(_ struct-id clause ...)
+     (let ()
+       (define info (get-struct-info #'struct-id stx))
+       (cond
+         [(ormap values (list-ref info 4))
+          ;; any mutable struct, just give up (could generate impersonator code, but
+          ;; would have to check that the compiled subcontracts are all chaperones/flats)
+          (opt/unknown opt/i opt/info stx)]
+         [else
+          (define-values (s-chap-code s-flat-code s-lifts s-super-lifts s-partially-applied can-be-optimized? stronger-ribs chaperone?)
+            (for/fold ([s-chap-code '()]
+                       [s-flat-code '()]
+                       [s-lifts '()]
+                       [s-super-lifts '()]
+                       [s-partially-applied '()]
+                       [can-be-optimized? #t]
+                       [stronger-ribs '()]
+                       [chaperone? #t])
+              ([clause (in-list (syntax->list #'(clause ...)))])
+              
+              (define-values (sel-id lazy? dep-vars exp)
+                (syntax-case clause ()
+                  [(sel-id #:lazy exp) (values #'sel-id #t #f #'exp)]
+                  [(sel-id exp) (values #'sel-id #f #f #'exp)]
+                  [(sel-id #:lazy (dep-id ...) exp) (values #'sel-id #t #'(dep-id ...) #'exp)]
+                  [(sel-id (dep-id ...) exp) (values #'sel-id #f #'(dep-id ...) #'exp)]))
+              
+              (define-values (this-code 
+                              this-lifts this-super-lifts this-partially-applied 
+                              this-flat? this-can-be-optimized? this-stronger-ribs
+                              this-chaperone?)
+                (opt/i opt/info exp))
+              
+              (values (cond
+                        [(and this-flat? (not lazy?) (not dep-vars))
+                         s-chap-code]
+                        [else
+                         (with-syntax ([(strct cache) (generate-temporaries '(struct cache))]
+                                       [proc-name (string->symbol
+                                                   (format "~a-~a-chap/dep" 
+                                                           (syntax-e #'struct-id)
+                                                           (syntax-e sel-id)))])
+                           (list* (cond
+                                    [dep-vars
+                                     (with-syntax ([(sel ...) (map (λ (var) (id->sel-id #'struct-id var)) 
+                                                                   (syntax->list dep-vars))]
+                                                   [(dep-var ...) dep-vars])
+                                       (with-syntax ([this-code+lifts
+                                                      #`(let ([dep-var (sel strct)] ...)
+                                                          #,(bind-superlifts
+                                                             this-super-lifts
+                                                             (bind-lifts
+                                                              this-lifts
+                                                              (bind-lifts
+                                                               this-partially-applied
+                                                               this-code))))])
+                                         (if lazy?
+                                             #`(let ([cache unique])
+                                                 (let ([proc-name
+                                                        (λ (strct #,(opt/info-val opt/info)) 
+                                                          (cond
+                                                            [(eq? cache unique)
+                                                             (set! cache this-code+lifts)
+                                                             cache]
+                                                            [else cache]))])
+                                                   proc-name))
+                                             #`(let ([proc-name
+                                                      (λ (strct #,(opt/info-val opt/info)) 
+                                                        this-code+lifts)])
+                                                 proc-name))))]
+                                    [else
+                                     (if lazy?
+                                         #`(let ([cache unique])
+                                             (let ([proc-name
+                                                    (λ (strct #,(opt/info-val opt/info))
+                                                      (cond
+                                                        [(eq? cache unique)
+                                                         (set! cache #,this-code)
+                                                         cache]
+                                                        [else cache]))])
+                                               proc-name))
+                                         #`(let ([proc-name
+                                                  (λ (strct #,(opt/info-val opt/info))
+                                                    #,this-code)])
+                                             proc-name))])
+                                  (id->sel-id #'struct-id sel-id)
+                                  s-chap-code))])
+                      (cond
+                        [lazy?
+                         s-flat-code]
+                        [dep-vars
+                         (with-syntax ([(sel ...) (map (λ (var) (id->sel-id #'struct-id var)) 
+                                                       (syntax->list dep-vars))]
+                                       [(dep-var ...) dep-vars])
+                           (cons #` (let ([dep-var (sel #,(opt/info-val opt/info))] ...)
+                                      (let ([#,(opt/info-val opt/info) (#,(id->sel-id #'struct-id sel-id)
+                                                                        #,(opt/info-val opt/info))])
+                                        #,this-code))
+                                 s-flat-code))]
+                        [else
+                         (cons #`(let ([#,(opt/info-val opt/info) (#,(id->sel-id #'struct-id sel-id)
+                                                                   #,(opt/info-val opt/info))])
+                                   #,this-code)
+                               s-flat-code)])
+                      (if dep-vars s-lifts (append this-lifts s-lifts))
+                      (if dep-vars s-super-lifts (append this-super-lifts s-super-lifts))
+                      (if dep-vars s-partially-applied (append this-partially-applied s-partially-applied))
+                      (and this-can-be-optimized? can-be-optimized?)
+                      (append this-stronger-ribs stronger-ribs)
+                      (and this-chaperone? chaperone?))))
+          (with-syntax ([(stronger-prop-desc stronger-prop-pred? stronger-prop-get)
+                         (syntax-local-lift-values-expression
+                          3
+                          #'(make-impersonator-property 'struct/dc-stronger-prop))]
+                        [(free-var ...) (opt/info-free-vars opt/info)]
+                        [(index ...) (build-list (length (opt/info-free-vars opt/info)) values)]
+                        [pred? (list-ref info 2)])
+            (values #`(if (and (stronger-prop-pred? #,(opt/info-val opt/info))
+                               (let ([v (stronger-prop-get #,(opt/info-val opt/info))])
+                                 (and (eq? (vector-ref v index) free-var) ...)))
+                          #,(opt/info-val opt/info)
+                          (if (pred? #,(opt/info-val opt/info))
+                              (begin
+                                #,@(reverse s-flat-code) ;; built the last backwards, so reverse it here
+                                (chaperone-struct
+                                 #,(opt/info-val opt/info)
+                                 #,@(reverse s-chap-code) ;; built the last backwards, so reverse it here
+                                 stronger-prop-desc
+                                 (vector free-var ...)))
+                              (struct/dc-error blame #,(opt/info-val opt/info) 'struct-name)))
+                    s-lifts
+                    s-super-lifts
+                    s-partially-applied
+                    #f  ;; flat sexp
+                    can-be-optimized?
+                    stronger-ribs
+                    #t  ;;chaperone?
+                    ))]))]))
+
+(define (struct/dc-error blame obj what)
+  (raise-blame-error blame obj 
+                     "expected a struct of type ~a"
+                     what))
diff --git a/collects/scribblings/reference/contracts.scrbl b/collects/scribblings/reference/contracts.scrbl
index f3cd1ef5ac..5e175b169c 100644
--- a/collects/scribblings/reference/contracts.scrbl
+++ b/collects/scribblings/reference/contracts.scrbl
@@ -385,7 +385,46 @@ Contracts for mutable fields may be impersonator contracts.
 If all fields are immutable and the @racket[contract-expr]s evaluate
 to flat contracts, a flat contract is produced.  If all the
 @racket[contract-expr]s are chaperone contracts, a chaperone contract is
-produced.  Otherwise, an impersonator contract is produced.}
+produced.  Otherwise, an impersonator contract is produced.
+}
+
+
+@defform/subs[(struct/dc struct-id field-spec ...)
+              ([field-spec [field-id contract-expr]
+                           [field-id #:lazy contract-expr]
+                           [field-id (dep-field-id ...) contract-expr]
+                           [field-id (dep-field-id ...) #:lazy contract-expr]])]{
+Produces a contract that recognizes instances of the structure
+type named by @racket[struct-id], and whose field values match the
+contracts produced by the @racket[field-spec]s.
+
+Each @racket[field-spec] can specify if the field is check lazily 
+(only when a selector is applied) or not via the @racket[#:lazy] 
+keyword. If the @racket[field-spec] lists the names of other fields,
+then the contract depends on values in those fields, and the @racket[contract-expr]
+expression is evaluated each time a selector is applied, building a new contract
+for the fields based on the values of the @racket[dep-field-id] fields.
+
+Contracts for immutable fields must be either flat or chaperone contracts.
+Contracts for mutable fields may be impersonator contracts.
+If all fields are immutable and the @racket[contract-expr]s evaluate
+to flat contracts, a flat contract is produced.  If all the
+@racket[contract-expr]s are chaperone contracts, a chaperone contract is
+produced.  Otherwise, an impersonator contract is produced.
+
+For example, the function @racket[bst/c] below 
+returns a contract for binary search trees whose values
+are all between @racket[lo] and @racket[hi].
+
+@racketblock[(struct bt (val left right))
+             (define (bst/c lo hi)
+               (or/c #f
+                     (struct/dc bt
+                                [val (between/c lo hi)]
+                                [left (val) (bst lo val)]
+                                [right (val) (bst val hi)])))]
+
+}
 
 
 @defproc[(parameter/c [c contract?]) contract?]{
diff --git a/collects/tests/racket/contract-test.rktl b/collects/tests/racket/contract-test.rktl
index b0d6e4618a..f856f96d3f 100644
--- a/collects/tests/racket/contract-test.rktl
+++ b/collects/tests/racket/contract-test.rktl
@@ -41,7 +41,7 @@
   (define (contract-error-test name exp exn-ok?)
     (test #t 
           name
-          (contract-eval `(with-handlers ((exn? (λ (x) (and (,exn-ok? x) #t)))) ,exp))))
+          (contract-eval `(with-handlers ((exn:fail? (λ (x) (and (,exn-ok? x) #t)))) ,exp))))
 
   (define (contract-syntax-error-test name exp [reg #rx""])
     (test #t
@@ -8632,6 +8632,270 @@
         (set-s-a! v* 4))))
 
   
+;                                                           
+;                                                           
+;                                                           
+;                                                           
+;           ;                         ;    ;    ;;;         
+;         ;;;                       ;;;    ;    ;;;         
+;   ;;;;  ;;;; ;;; ;;;; ;;;   ;;;   ;;;;  ;  ;; ;;;   ;;;   
+;  ;;; ;; ;;;; ;;;;;;;; ;;;  ;;;;;  ;;;;  ; ;;;;;;;  ;;;;;  
+;  ;;;    ;;;  ;;;  ;;; ;;; ;;;  ;; ;;;   ; ;;; ;;; ;;;  ;; 
+;   ;;;;  ;;;  ;;;  ;;; ;;; ;;;     ;;;   ; ;;; ;;; ;;;     
+;     ;;; ;;;  ;;;  ;;; ;;; ;;;  ;; ;;;   ; ;;; ;;; ;;;  ;; 
+;  ;; ;;; ;;;; ;;;  ;;;;;;;  ;;;;;  ;;;; ;  ;;;;;;;  ;;;;;  
+;   ;;;;   ;;; ;;;   ;; ;;;   ;;;    ;;; ;   ;; ;;;   ;;;   
+;                                                           
+;                                                           
+;                                                           
+;                                                           
+
+  
+  (test/spec-passed
+   'struct/dc-1
+   '(let ()
+      (struct s (a b))
+      (contract (struct/dc s 
+                         [a () number?]
+                         [b (a) boolean?])
+              (s 1 #f)
+              'pos
+              'neg)))
+
+  (test/spec-passed
+   'struct/dc-2
+   '(let ()
+      (struct s (a b))
+      (contract (struct/dc s 
+                           [a () number?]
+                           [b (a) (>=/c a)])
+                (s 1 2)
+                'pos
+                'neg)))
+
+  (test/pos-blame
+   'struct/dc-3
+   '(let ()
+      (struct s (a b))
+      (contract (struct/dc s 
+                         [a () number?]
+                         [b (a) (>=/c a)])
+              (s 2 1)
+              'pos
+              'neg)))
+  
+  (test/spec-passed
+   'struct/dc-3b
+   '(let ()
+      (struct s (a b))
+      (contract (struct/dc s 
+                         [a () number?]
+                         [b (a) (<=/c a)])
+              (s 2 1)
+              'pos
+              'neg)))
+
+  (test/spec-passed
+   'struct/dc-4
+   '(let ()
+      (struct s (a b))
+      (contract (struct/dc s 
+                           [a number?]
+                           [b (a) (>=/c a)])
+                (s 1 2)
+                'pos
+                'neg)))
+
+
+  (test/pos-blame
+   'struct/dc-5
+   '(let ()
+      (struct s (a b))
+      (s-b (contract (struct/dc s 
+                                [a () number?]
+                                [b (a) (>=/c a)])
+                     (s 2 1)
+                     'pos
+                     'neg))))
+   
+  (test/spec-passed/result
+   'struct/dc-6
+   '(let ()
+      (struct s (a b))
+      (define-opt/c (f z)
+        (struct/dc s
+                   [a (>=/c z)]
+                   [b #:lazy (a) (f a)]))
+      
+      (s-a (contract (f 11)
+                     (s 12 (s 13 #f))
+                     'pos
+                     'neg)))
+   12)
+  
+  (test/spec-passed/result
+   'struct/dc-7
+   '(let ()
+      (struct s (a b))
+      (define-opt/c (f z)
+        (struct/dc s
+                   [a (>=/c z)]
+                   [b #:lazy (a) (f a)]))
+      
+      (s-a (s-b (contract (f 11)
+                            (s 12 (s 13 #f))
+                            'pos
+                            'neg))))
+   13)
+  
+  
+  (test/pos-blame
+   'struct/dc-8
+   '(let ()
+      (struct s (a b))
+      (define-opt/c (f z)
+        (struct/dc s
+                   [a (>=/c z)]
+                   [b #:lazy (a) (f a)]))
+      (s-b (s-b (contract (f 11)
+                          (s 12 (s 13 #f))
+                          'pos
+                          'neg)))))
+  
+  
+  (test/spec-passed/result
+   'struct/dc-9
+   '(let ()
+      (struct s (a b))
+      
+      (define-opt/c (g z)
+        (struct/dc s
+                   [a (>=/c z)]
+                   [b #:lazy (a) (>=/c (+ a 1))]))
+      
+      (s-a (contract (g 10)
+                     (s 12 (s 14 #f))
+                     'pos
+                     'neg)))
+   12)
+
+  (test/spec-passed/result
+   'struct/dc-10
+   '(let ()
+      (struct s (a b))
+      
+      (define-opt/c (g z)
+        (struct/dc s
+                   [a (>=/c z)]
+                   [b #:lazy (a) (>=/c (+ a 1))]))
+      
+      (s-b (contract (g 10)
+                     (s 12 14)
+                     'pos
+                     'neg)))
+   14)
+  
+  (test/pos-blame
+   'struct/dc-11
+   '(let ()
+      
+      (struct s (a b))
+      
+      (define-opt/c (g z)
+        (struct/dc s
+                   [a (>=/c z)]
+                   [b #:lazy (a) (>=/c (+ a 1))]))
+      
+      (s-b (contract (g 11)
+                     (s 12 10)
+                     'pos
+                     'neg))))
+  
+  (test/spec-passed/result
+   'struct/dc-12
+   '(let ()
+      (struct kons (hd tl) #:transparent)
+      (define (unknown-function a) (=/c a))
+      (define-opt/c (f a b)
+        (or/c not
+              (struct/dc kons
+                         [hd (unknown-function a)]
+                         [tl #:lazy () (or/c #f (f b a))])))
+      (kons-hd (kons-tl (contract (f 1 2)
+                                  (kons 1 (kons 2 #f))
+                                  'pos
+                                  'neg))))
+   2)
+
+  (test/spec-passed
+   'struct/dc-13
+   '(let ()
+      (struct s (a))
+      (contract (struct/dc s
+                           [a #:lazy integer?])
+                (s #f)
+                'pos
+                'neg)))
+  
+  (test/spec-passed
+   'struct/dc-14
+   '(let ()
+      (struct s (a))
+      (contract (struct/dc s
+                           [a #:lazy (-> integer? integer?)])
+                (s #f)
+                'pos
+                'neg)))
+  
+  (test/pos-blame
+   'struct/dc-15
+   '(let ()
+      (struct s (a))
+      (contract (struct/dc s
+                           [a integer?])
+                (s #f)
+                'pos
+                'neg)))
+  
+  (test/pos-blame
+   'struct/dc-16
+   '(let ()
+      (struct s (a))
+      (contract (struct/dc s
+                           [a (-> integer? integer?)])
+                (s #f)
+                'pos
+                'neg)))
+  
+  (test/spec-passed
+   'struct/dc-17
+   '(let ()
+      (struct s (q a))
+      (contract (struct/dc s
+                           [q integer?]
+                           [a #:lazy (q) (<=/c a)])
+                (s 1 #f)
+                'pos
+                'neg)))
+  
+  (test/pos-blame
+   'struct/dc-18
+   '(let ()
+      (struct s (q a))
+      (contract (struct/dc s
+                           [q integer?]
+                           [a (q) (<=/c q)])
+                (s 1 #f)
+                'pos
+                'neg)))
+  
+  (contract-error-test
+   'struct/dc-19
+   '(let ()
+      (struct s (a b))
+      (struct/dc s [a (new-∃/c 'α)]))
+   exn:fail?)
+  
 ;                                                                              
 ;                                                                              
 ;                                                                              
@@ -9411,6 +9675,18 @@
                                   #f)))))
    178)
   
+  (test/spec-passed/result
+   'd-o/c27
+   '(let ()
+      (define-opt/c (f x)
+        (and/c (>=/c x)
+               (g x)))
+      (define-opt/c (g x)
+        (<=/c x))
+      (contract (f 11) 11 'pos 'neg))
+   11)
+  
+  
   ;;
   ;;  end of define-opt/c
   ;;
@@ -9802,6 +10078,19 @@ so that propagation occurs.
   (ctest #t contract? 1)
   (ctest #t contract? (-> 1 1))
   
+  (ctest #t chaperone-contract? (let ()
+                                  (struct s (a b))
+                                  (struct/dc s [a integer?] [b integer?])))
+  (ctest #f flat-contract? (let ()
+                             (struct s (a b))
+                             (struct/dc s [a integer?] [b integer?])))
+  (ctest #f flat-contract? (let ()
+                             (struct s (a b))
+                             (struct/dc s [a integer?] [b (a) (>=/c a)])))
+  (ctest #t chaperone-contract? (let ()
+                                  (struct s (a b))
+                                  (struct/dc s [a integer?] [b (a) (>=/c a)])))
+  
   (test-flat-contract '(and/c number? integer?) 1 3/2)
 
   (test-flat-contract '(not/c integer?) #t 1)
@@ -10426,7 +10715,56 @@ so that propagation occurs.
         (,test #t contract-stronger? (mk-c 1) (mk-c 2)))))
 
   
+  (contract-eval
+   `(let ()
 
+      (struct s (a b))
+      (struct t (a b))
+
+      (,test #f contract-stronger?
+             (struct/dc s
+                        [a (>=/c 1)]
+                        [b (>=/c 2)])
+             (struct/dc s
+                        [a (>=/c 2)]
+                        [b (>=/c 3)]))
+      (,test #t contract-stronger?
+              (struct/dc s
+                         [a (>=/c 2)]
+                         [b (>=/c 3)])
+              (struct/dc s
+                         [a (>=/c 1)]
+                         [b (>=/c 2)]))
+
+      (,test #f contract-stronger?
+             (struct/dc s
+                    [a number?]
+                    [b number?])
+             (struct/dc t
+                        [a number?]
+                        [b number?]))
+      
+      (,test #f contract-stronger?
+             (struct/dc t
+                        [a number?]
+                        [b number?])
+             (struct/dc s
+                        [a number?]
+                        [b number?]))
+
+      (define (mk c)
+        (struct/dc s
+                   [a (>=/c c)]
+                   [b (a) (>=/c a)]))
+      (define one (mk 1))
+      (define two (mk 2))
+      (,test #f contract-stronger? one two)
+      (,test #t contract-stronger? two one)))
+
+
+
+  
+  
 ;                                                                                    
 ;                                                                                    
 ;