diff --git a/collects/racket/contract/private/struct.rkt b/collects/racket/contract/private/struct.rkt
index 6f1c91e1a6..96ea124a32 100644
--- a/collects/racket/contract/private/struct.rkt
+++ b/collects/racket/contract/private/struct.rkt
@@ -1,105 +1,226 @@
 #lang racket/base
 
 (require (for-syntax racket/base
-                     racket/struct-info
-                     "helpers.rkt")
+                     racket/list
+                     racket/struct-info)
+         racket/list
          "guts.rkt")
 
 (provide struct/c)
 
-#|
-  as with copy-struct in struct.rkt, this first begin0
-  expansion "declares" that struct/c is an expression.
-  It prevents further expansion until the internal definition
-  context is sorted out.
-|#
 (define-syntax (struct/c stx)
   (syntax-case stx ()
     [(_ . args) 
      (with-syntax ([x (syntax/loc stx (do-struct/c . args))])
-       (syntax/loc stx (begin0 x)))]))
+       (syntax/loc stx (#%expression x)))]))
+
+;; name is symbol
+;; predicate is (-> any bool)
+;; immutables is (listof (list natural contract selector-proc))
+;; mutables is (listof (list natural contract selector-proc mutator-proc))
+(define-struct base-struct/c (name predicate immutables mutables))
+
+(define (struct/c-name ctc)
+  (let ([ctcs (map second
+                   (sort (append (base-struct/c-immutables ctc) (base-struct/c-mutables ctc))
+                         < #:key first))])
+    (apply build-compound-type-name 'struct/c (base-struct/c-name ctc) ctcs)))
+
+(define (check-struct/c ctc)
+  (let ([name (base-struct/c-name ctc)]
+        [pred? (base-struct/c-predicate ctc)]
+        [ctc/ref-pairs (map (λ (l) (cons (second l) (third l)))
+                            (append (base-struct/c-immutables ctc) (base-struct/c-mutables ctc)))])
+    (λ (val fail [first-order? #f])
+      (unless (pred? val)
+        (fail "expected <~a>, got ~e" name val))
+      (when first-order?
+        (for ([p (in-list ctc/ref-pairs)])
+          (let ([c (car p)] [v ((cdr p) val)])
+            (unless (contract-first-order-passes? c v)
+              (fail "expected <~a>, got ~e" (contract-name c) v)))))
+      #t)))
+
+(define (struct/c-first-order ctc)
+  (let ([f (check-struct/c ctc)])
+    (λ (val)
+      (let/ec fail
+        (f val (λ args (fail #f)) #t)))))
+
+(define (flat-struct/c-proj ctc)
+  (let ([checker (check-struct/c ctc)]
+        [name (base-struct/c-name ctc)]
+        [pred (base-struct/c-predicate ctc)]
+        [projs (map contract-projection (map second (base-struct/c-immutables ctc)))]
+        [refs (map third (base-struct/c-immutables ctc))])
+    (λ (blame)
+      (let ([pos-projs (map (λ (f) (f blame)) projs)])
+        (λ (val)
+          (checker val (λ args (apply raise-blame-error blame val args)))
+          (for ([p (in-list pos-projs)] [ref (in-list refs)])
+            (p (ref val)))
+          val)))))
+
+(define-struct (flat-struct/c base-struct/c) ()
+  #:property prop:flat-contract
+  (build-flat-contract-property
+   #:name struct/c-name
+   #:first-order struct/c-first-order
+   #:projection flat-struct/c-proj))
+
+(define (chaperone-struct/c-proj ctc)
+  (let-values ([(flat-imms chap-imms)
+                (partition (λ (l) (flat-contract? (second l))) (base-struct/c-immutables ctc))])
+    (let ([checker (check-struct/c ctc)]
+          [name (base-struct/c-name ctc)]
+          [pred (base-struct/c-predicate ctc)]
+          [flat-imm-projs (map (compose contract-projection second) flat-imms)]
+          [flat-imm-refs (map third flat-imms)]
+          [chap-imm-projs (map (compose contract-projection second) chap-imms)]
+          [chap-imm-refs (map third chap-imms)]
+          [mut-projs (map (compose contract-projection second) (base-struct/c-mutables ctc))]
+          [mut-refs (map third (base-struct/c-mutables ctc))]
+          [mut-sets (map fourth (base-struct/c-mutables ctc))])
+      (λ (blame)
+        (let* ([swapped-blame (blame-swap blame)]
+               [flat-imm-pos-projs (map (λ (f) (f blame)) flat-imm-projs)]
+               [chap-imm-pos-projs (map (λ (f) (f blame)) chap-imm-projs)]
+               [mut-pos-projs (map (λ (f) (f blame)) mut-projs)]
+               [mut-neg-projs (map (λ (f) (f swapped-blame)) mut-projs)])
+          (λ (val)
+            (checker val (λ args (apply raise-blame-error blame val args)))
+            (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))))))))))
+
+(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))
+
+(define (impersonator-struct/c-proj ctc)
+  (let-values ([(flat-imms chap-imms)
+                (partition (λ (l) (flat-contract? (second l))) (base-struct/c-immutables ctc))])
+    (let ([checker (check-struct/c ctc)]
+          [name (base-struct/c-name ctc)]
+          [pred (base-struct/c-predicate ctc)]
+          [flat-imm-projs (map (compose contract-projection second) flat-imms)]
+          [flat-imm-refs (map third flat-imms)]
+          [chap-imm-projs (map (compose contract-projection second) chap-imms)]
+          [chap-imm-refs (map third chap-imms)]
+          [mut-projs (map (compose contract-projection second) (base-struct/c-mutables ctc))]
+          [mut-refs (map third (base-struct/c-mutables ctc))]
+          [mut-sets (map fourth (base-struct/c-mutables ctc))])
+      (λ (blame)
+        (let* ([swapped-blame (blame-swap blame)]
+               [flat-imm-pos-projs (map (λ (f) (f blame)) flat-imm-projs)]
+               [chap-imm-pos-projs (map (λ (f) (f blame)) chap-imm-projs)]
+               [mut-pos-projs (map (λ (f) (f blame)) mut-projs)]
+               [mut-neg-projs (map (λ (f) (f swapped-blame)) mut-projs)])
+          (λ (val)
+            (checker val (λ args (apply raise-blame-error blame val args)))
+            (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 impersonate-struct
+                     (apply chaperone-struct val
+                            combined-imm-refs)
+                     (flatten (list combined-mut-refs combined-mut-sets
+                                    impersonator-prop:contracted ctc))))))))))
+
+(define-struct (impersonator-struct/c base-struct/c) ()
+  #:property prop:contract
+  (build-contract-property
+   #:name struct/c-name
+   #:first-order struct/c-first-order
+   #:projection impersonator-struct/c-proj))
 
 (define-syntax (do-struct/c stx)
   (syntax-case stx ()
     [(_ struct-name args ...)
      (and (identifier? (syntax struct-name))
           (struct-info? (syntax-local-value (syntax struct-name) (λ () #f))))
-     (with-syntax ([(ctc-x ...) (generate-temporaries (syntax (args ...)))]
-                   [(ctc-name-x ...) (generate-temporaries (syntax (args ...)))]
-                   [(ctc-pred-x ...) (generate-temporaries (syntax (args ...)))]
-                   [(ctc-proj-x ...) (generate-temporaries (syntax (args ...)))]
-                   [(ctc-pos-proj-x ...) (generate-temporaries (syntax (args ...)))]
-                   [(ctc-neg-proj-x ...) (generate-temporaries (syntax (args ...)))]
-                   [(ctc-app-x ...) (generate-temporaries (syntax (args ...)))]
-                   [(field-numbers ...)
-                    (let loop ([i 0]
-                               [l (syntax->list (syntax (args ...)))])
-                      (cond
-                        [(null? l) '()]
-                        [else (cons i (loop (+ i 1) (cdr l)))]))]
-                   [(type-desc-id 
-                     constructor-id 
-                     predicate-id 
-                     (rev-selector-id ...)
-                     (rev-mutator-id ...)
-                     super-id)
-                    (lookup-struct-info (syntax struct-name) stx)])
-       (unless (= (length (syntax->list (syntax (rev-selector-id ...))))
-                  (length (syntax->list (syntax (args ...)))))
+     (let* ([si (extract-struct-info (syntax-local-value (syntax struct-name)))]
+            [predicate-id (third si)]
+            [selector-ids (reverse (fourth si))]
+            [mutator-ids (reverse (fifth si))]
+            [ctcs (syntax->list #'(args ...))]
+            [ctc-names (generate-temporaries #'(args ...))])
+       (unless (= (length selector-ids) (length ctcs))
          (raise-syntax-error 'struct/c 
                              (format "expected ~a contracts because struct ~a has ~a fields"
-                                     (length (syntax->list (syntax (rev-selector-id ...))))
+                                     (length selector-ids)
                                      (syntax-e #'struct-name)
-                                     (length (syntax->list (syntax (rev-selector-id ...)))))
+                                     (length selector-ids))
                              stx))
-       (with-syntax ([(selector-id ...) (reverse (syntax->list (syntax (rev-selector-id ...))))]
-                     [(mutator-id ...)  (reverse (syntax->list (syntax (rev-mutator-id ...))))])
-         (syntax
-          (let ([ctc-x (coerce-contract 'struct/c args)] ...)
-            
-            (unless predicate-id
-              (error 'struct/c "could not determine predicate for ~s" 'struct-name))
-            (unless (and selector-id ...)
-              (error 'struct/c "could not determine selectors for ~s" 'struct-name))
-            (unless (chaperone-contract? ctc-x)
-              (error 'struct/c "expected chaperone contracts as arguments, got ~e" args))
-            ...
-            
-            (let* ([ctc-pred-x (contract-first-order ctc-x)] 
-                   ...
-                   [ctc-name-x (contract-name ctc-x)]
-                   ...
-                   ;; To have a flat contract result, all of the contracted fields must be immutable
-                   ;; and all the contracts must be flat.
-                   [flat? (and (andmap not (list mutator-id ...))
-                               (for/and ([c (in-list (list ctc-x ...))])
-                                 (flat-contract? c)))]
-                   [fo-check (λ (val)
-                               (and (predicate-id val)
-                                    (ctc-pred-x (selector-id val)) ...))])
-              (if flat?
-                  (build-flat-contract
-                   (build-compound-type-name 'struct/c 'struct-name ctc-x ...)
-                   fo-check)
-                  (make-chaperone-contract
-                   #:name (build-compound-type-name 'struct/c 'struct-name ctc-x ...)
-                   #:first-order fo-check
-                   #:projection
-                   (let ([ctc-proj-x (contract-projection ctc-x)] ...)
-                     (λ (blame)
-                       (let* ([swapped-blame (blame-swap blame)]
-                              [ctc-pos-proj-x (ctc-proj-x blame)] ...
-                              [ctc-neg-proj-x (ctc-proj-x swapped-blame)] ...)
-                         (λ (val)
-                           (unless (predicate-id val)
-                             (raise-blame-error blame val "expected a <~a>, got ~v" struct-name val))
-                           ;; Do first order checks on values in case the struct doesn't adhere to them
-                           ;; at wrapping time
-                           (ctc-pos-proj-x (selector-id val)) ...
-                           (apply chaperone-struct val
-                                  (append (list* selector-id (λ (s v) (ctc-pos-proj-x v))
-                                                 (if mutator-id
-                                                     (list mutator-id (λ (s v) (ctc-neg-proj-x v)))
-                                                     null)) ...)))))))))))))]
+       (unless predicate-id
+         (error 'struct/c "could not determine predicate for ~s" 'struct-name))
+       (unless (andmap values selector-ids)
+         (error 'struct/c "could not determine selectors for ~s" 'struct-name))
+       
+       (let ([combined-ids (for/list ([n (in-naturals)]
+                                      [ctc-name (in-list ctc-names)]
+                                      [ref-name (in-list selector-ids)]
+                                      [mut-name (in-list mutator-ids)])
+                             (list n ctc-name ref-name mut-name))])
+         (let-values ([(mutables immutables) (partition (λ (l) (fourth l)) combined-ids)])
+           (with-syntax ([(ctc-x ...) ctc-names]
+                         [predicate-id predicate-id]
+                         [((imm-count imm-ctc-x imm-ref _) ...) immutables]
+                         [((mut-count mut-ctc-x mut-ref mut-set) ...) mutables])
+             (syntax
+              (let ([ctc-x (coerce-contract 'struct/c args)] ...)
+                
+                (unless (chaperone-contract? imm-ctc-x)
+                  (error 'struct/c "expected a chaperone contract for immutable field ~v, got ~e"
+                         imm-count imm-ctc-x))
+                ...
+                
+                (let ([immutables (list (list imm-count imm-ctc-x imm-ref) ...)]
+                      [mutables (list (list mut-count mut-ctc-x mut-ref mut-set) ...)])
+                  (cond
+                    [(and (null? mutables) (andmap (λ (l) (flat-contract? (second l))) immutables))
+                     (make-flat-struct/c 'struct-name predicate-id immutables mutables)]
+                    [(andmap (λ (l) (chaperone-contract? (second l))) mutables)
+                     (make-chaperone-struct/c 'struct-name predicate-id immutables mutables)]
+                    [else
+                     (make-impersonator-struct/c 'struct-name predicate-id immutables mutables)]))))))))]
     [(_ struct-name anything ...)
      (raise-syntax-error 'struct/c "expected a struct identifier" stx (syntax struct-name))]))
diff --git a/collects/scribblings/reference/contracts.scrbl b/collects/scribblings/reference/contracts.scrbl
index 6ed0c772b8..f30874347c 100644
--- a/collects/scribblings/reference/contracts.scrbl
+++ b/collects/scribblings/reference/contracts.scrbl
@@ -345,15 +345,17 @@ Produces a flat contract that recognizes syntax objects whose
 @racket[syntax-e] content matches @racket[c].}
 
 
-@defform[(struct/c struct-id chaperone-contract-expr ...)]{
-
+@defform[(struct/c struct-id contract-expr ...)]{
 Produces a contract that recognizes instances of the structure
 type named by @racket[struct-id], and whose field values match the
-chaperone contracts produced by the @racket[chaperone-contract-expr]s.
+contracts produced by the @racket[contract-expr]s.
 
-If the fields are immutable and the @racket[chaperone-contract-expr]s evaluate
-to flat contracts, a flat contract is produced. Otherwise, a chaperone
-contract is produced.}
+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.}
 
 
 @defproc[(parameter/c [c contract?]) contract?]{
diff --git a/collects/tests/racket/contract-test.rktl b/collects/tests/racket/contract-test.rktl
index 4d887afe94..2d9d270441 100644
--- a/collects/tests/racket/contract-test.rktl
+++ b/collects/tests/racket/contract-test.rktl
@@ -8007,6 +8007,26 @@
                          'pos
                          'neg)])
         (set-s-b! v 5))))
+  
+  (test/spec-passed/result
+   'struct/c12
+   '(let ()
+      (define-struct s (a) #:mutable)
+      (define alpha (new-∃/c 'alpha))
+      (define v (make-s 3))
+      (let ([v* (contract (struct/c s alpha) v 'pos 'neg)])
+        (set-s-a! v* (s-a v*)))
+      (s-a v))
+   3)
+  
+  (test/neg-blame
+   'struct/c13
+   '(let ()
+      (define-struct s (a) #:mutable)
+      (define alpha (new-∃/c 'alpha))
+      (define v (make-s 3))
+      (let ([v* (contract (struct/c s alpha) v 'pos 'neg)])
+        (set-s-a! v* 4))))
 
   
 ;                                                                              
@@ -8980,19 +9000,44 @@ so that propagation occurs.
   (ctest #t flat-contract? (let ()
                              (define-struct s (a b))
                              (struct/c s any/c any/c)))
+  (ctest #f flat-contract? (let ()
+                             (define-struct s (a b) #:mutable)
+                             (struct/c s any/c any/c)))
   (ctest #t chaperone-contract? (let ()
                                   (define-struct s (a b) #:mutable)
                                   (struct/c s any/c any/c)))
+  (ctest #f flat-contract? (let ()
+                             (define-struct s ([a #:mutable] b))
+                             (struct/c s any/c any/c)))
   (ctest #t chaperone-contract? (let ()
                                   (define-struct s ([a #:mutable] b))
                                   (struct/c s any/c any/c)))
+  (ctest #f flat-contract? (let ()
+                             (define-struct s (a [b #:mutable]))
+                             (struct/c s any/c any/c)))
   (ctest #t chaperone-contract? (let ()
                                   (define-struct s (a [b #:mutable]))
                                   (struct/c s any/c any/c)))
+  (ctest #f flat-contract? (let ()
+                             (define-struct s (f))
+                             (struct/c s (-> number? any))))
   (ctest #t chaperone-contract? (let ()
                                   (define-struct s (f))
                                   (struct/c s (-> number? any))))
   
+  (ctest #f flat-contract? (let ()
+                             (define-struct s (a) #:mutable)
+                             (define alpha (new-∃/c 'alpha))
+                             (struct/c s alpha)))
+  (ctest #f chaperone-contract? (let ()
+                                  (define-struct s (a) #:mutable)
+                                  (define alpha (new-∃/c 'alpha))
+                                  (struct/c s alpha)))
+  (ctest #t contract? (let ()
+                        (define-struct s (a) #:mutable)
+                        (define alpha (new-∃/c 'alpha))
+                        (struct/c s alpha)))
+  
   ;; Hash contracts with flat domain/range contracts
   (ctest #t contract?           (hash/c any/c any/c #:immutable #f))
   (ctest #t chaperone-contract? (hash/c any/c any/c #:immutable #f))