diff --git a/pkgs/racket-doc/scribblings/reference/contracts.scrbl b/pkgs/racket-doc/scribblings/reference/contracts.scrbl
index 487a0b3899..fc6313f011 100644
--- a/pkgs/racket-doc/scribblings/reference/contracts.scrbl
+++ b/pkgs/racket-doc/scribblings/reference/contracts.scrbl
@@ -2024,8 +2024,8 @@ flat contracts do not need to supply an explicit projection.
 The @racket[stronger] argument is used to implement @racket[contract-stronger?]. The
 first argument is always the contract itself and the second argument is whatever
 was passed as the second argument to @racket[contract-stronger?]. If no
-@racket[stronger] argument is supplied, then a default that always returns
-@racket[#f] is used.
+@racket[stronger] argument is supplied, then a default that compares its arguments
+with @racket[equal?] is used.
 
 The @racket[is-list-contract?] argument is used by the @racket[list-contract?] predicate
 to determine if this is a contract that accepts only @racket[list?] values.
@@ -2721,6 +2721,9 @@ are below):
   Returns @racket[#t] if the contract @racket[x] accepts either fewer
   or the same number of values as @racket[y] does.
 
+  Contracts that are the same (i.e., where @racket[x] is @racket[equal?]
+  to @racket[y]) are considered to always be stronger than each other.
+  
   This function is conservative, so it may return @racket[#f] when
   @racket[x] does, in fact, accept fewer values.
 
@@ -2730,8 +2733,8 @@ are below):
                  (contract-stronger? (between/c 0 100) (between/c 25 75))
                  (contract-stronger? (between/c -10 0) (between/c 0 10))
 
-                 (contract-stronger? (λ (x) (and (real? x) (<= x (random 10))))
-                                     (λ (x) (and (real? x) (<= x (+ 100 (random 10))))))]
+                 (contract-stronger? (λ (x) (and (real? x) (<= x 0)))
+                                     (λ (x) (and (real? x) (<= x 100))))]
 
 
 }
diff --git a/pkgs/racket-test/tests/racket/contract/arrow.rkt b/pkgs/racket-test/tests/racket/contract/arrow.rkt
index 9d436e3bcc..c0de59f415 100644
--- a/pkgs/racket-test/tests/racket/contract/arrow.rkt
+++ b/pkgs/racket-test/tests/racket/contract/arrow.rkt
@@ -340,6 +340,21 @@
           ;; pass; this is fixed in a separate branch that can't 
           (regexp-match #rx"expected:? keyword argument #:the-missing-keyword-arg-b"
                         (exn-message x)))))
+
+  ;; need to preserve the inner contract here
+  ;; (not the outer one)
+  ;; when dropping redundant tail contracts
+  (test/pos-blame
+   'tail-wrapping-preserves-blame
+   '(let ([c (-> number? number?)])
+      ((contract
+        c
+        (contract
+         c
+         (λ (x) #f)
+         'pos 'neg)
+        'something-else 'yet-another-thing)
+       1)))
   
   (test/pos-blame
    'predicate/c1
diff --git a/pkgs/racket-test/tests/racket/contract/tail.rkt b/pkgs/racket-test/tests/racket/contract/tail.rkt
index 708b376ce0..024f0fe544 100644
--- a/pkgs/racket-test/tests/racket/contract/tail.rkt
+++ b/pkgs/racket-test/tests/racket/contract/tail.rkt
@@ -85,6 +85,29 @@
                    (c)))
   
   (ctest/rewrite '(1)
+                 mut-rec-with-any
+                 (let ()
+                   (define f
+                     (contract (-> number? any)
+                               (lambda (x)
+                                 (if (zero? x)
+                                     (continuation-mark-set->list (current-continuation-marks)
+                                                                  'tail-test)
+                                     (with-continuation-mark 'tail-test x
+                                       (g (- x 1)))))
+                               'something-that-is-not-pos
+                               'neg))
+                   
+                   (define g
+                     (contract (-> number? any)
+                               (lambda (x)
+                                 (f x))
+                               'also-this-is-not-pos
+                               'neg))
+                   
+                   (f 3)))
+
+  (ctest/rewrite '(1 2 3)
                  mut-rec-with-any/c
                  (let ()
                    (define f
diff --git a/racket/collects/racket/contract/private/arrow-higher-order.rkt b/racket/collects/racket/contract/private/arrow-higher-order.rkt
index 7e7ac58481..8c72a5cdde 100644
--- a/racket/collects/racket/contract/private/arrow-higher-order.rkt
+++ b/racket/collects/racket/contract/private/arrow-higher-order.rkt
@@ -32,15 +32,15 @@
                 [(optional-dom-kwd-proj ...) (nvars (length optional-dom-kwds) 'optional-dom-proj)]
                 [(rng-proj ...) (if rngs (generate-temporaries rngs) '())]
                 [(rest-proj ...) (if rest (generate-temporaries '(rest-proj)) '())])
-    #`(λ (blame f neg-party
+    #`(λ (blame f neg-party blame-party-info rng-ctcs
                 mandatory-dom-proj ...  
                 optional-dom-proj ... 
                 rest-proj ...
                 mandatory-dom-kwd-proj ... 
                 optional-dom-kwd-proj ... 
                 rng-proj ...)
-        #,(create-chaperone 
-           #'blame #'f
+        #,(create-chaperone
+           #'blame #'neg-party #'blame-party-info #'f #'rng-ctcs
            this-args
            (syntax->list #'(mandatory-dom-proj ...))
            (syntax->list #'(optional-dom-proj ...))
@@ -114,7 +114,8 @@
       (if pre? "pre" "post")
       condition-result)]))
 
-(define-for-syntax (create-chaperone blame val  
+(define-for-syntax (create-chaperone blame neg-party blame-party-info
+                                     val rng-ctcs
                                      this-args
                                      doms opt-doms
                                      req-kwds opt-kwds
@@ -150,7 +151,7 @@
                     [(opt-kwd ...) (map car opt-kwds)]
                     [(opt-kwd-ctc ...) (map cadr opt-kwds)]
                     [(opt-kwd-x ...) (generate-temporaries (map car opt-kwds))]
-                    [(rng-ctc ...) (if rngs rngs '())]
+                    [(rng-late-neg-projs ...) (if rngs rngs '())]
                     [(rng-x ...) (if rngs (generate-temporaries rngs) '())])
         (with-syntax ([(rng-checker-name ...)
                        (if rngs
@@ -161,7 +162,7 @@
                            (list
                             (with-syntax ([rng-len (length rngs)])
                               (with-syntax ([rng-results
-                                             #'(values (rng-ctc rng-x neg-party)
+                                             #'(values (rng-late-neg-projs rng-x neg-party)
                                                        ...)])
                                 #'(case-lambda
                                     [(rng-x ...)
@@ -248,7 +249,9 @@
                                                   dom-projd-args ...)))])
                                (if no-rng-checking?
                                    (inner-stx-gen #'())
-                                   (arrow:check-tail-contract #'(rng-ctc ...)
+                                   (arrow:check-tail-contract rng-ctcs
+                                                              blame-party-info
+                                                              neg-party
                                                               #'(rng-checker-name ...)
                                                               inner-stx-gen)))]
                             [kwd-return
@@ -273,7 +276,9 @@
                                #`(let ([kwd-results kwd-stx])
                                    #,(if no-rng-checking?
                                          (outer-stx-gen #'())
-                                         (arrow:check-tail-contract #'(rng-ctc ...) 
+                                         (arrow:check-tail-contract rng-ctcs
+                                                                    blame-party-info
+                                                                    neg-party
                                                                     #'(rng-checker-name ...)
                                                                     outer-stx-gen))))])
                 (with-syntax ([basic-lambda-name (gen-id 'basic-lambda)]
@@ -398,12 +403,15 @@
               man-then-opt-partial-kwds
               partial-ranges
               (if partial-rest (list partial-rest) '())))
-
+    (define blame-party-info (arrow:get-blame-party-info orig-blame))
     (define (successfully-got-the-right-kind-of-function val neg-party)
-      (define chap/imp-func (apply chaperone-constructor orig-blame val neg-party the-args))
+      (define chap/imp-func (apply chaperone-constructor
+                                   orig-blame val
+                                   neg-party blame-party-info
+                                   rngs the-args))
       (cond
         [chap/imp-func
-         (if post?
+         (if (or post? (not rngs))
              (chaperone-or-impersonate-procedure
               val
               chap/imp-func
@@ -414,9 +422,8 @@
               chap/imp-func
               impersonator-prop:contracted ctc
               impersonator-prop:blame (blame-add-missing-party orig-blame neg-party)
-              impersonator-prop:application-mark (cons arrow:contract-key 
-                                                       ;; is this right?
-                                                       partial-ranges)))]
+              impersonator-prop:application-mark
+              (cons arrow:tail-contract-key (list* neg-party blame-party-info rngs))))]
         [else val]))
     
     (cond
diff --git a/racket/collects/racket/contract/private/arrow-val-first.rkt b/racket/collects/racket/contract/private/arrow-val-first.rkt
index a5ae6a5fe3..8e229e3c95 100644
--- a/racket/collects/racket/contract/private/arrow-val-first.rkt
+++ b/racket/collects/racket/contract/private/arrow-val-first.rkt
@@ -895,7 +895,7 @@
                                       optional-keywords
                                       (and rest-contract #t)
                                       rng-len)
-        (λ (blame f neg-party . args)
+        (λ (blame f neg-party blame-party-info rng-ctc-x . args)
           (define-next next args)
           (define mandatory-dom-projs (next min-arity))
           (define optional-dom-projs (next optionals))
@@ -1242,7 +1242,7 @@
     (make--> 0 '() '() #f #f
              (list (coerce-contract 'whatever void?))
              #f
-             (λ (blame f _ignored-rng-contract)
+             (λ (blame f _ignored-rng-ctcs _ignored-rng-proj)
                (λ (neg-party)
                  (call-with-values
                   (λ () (f))
@@ -1276,7 +1276,11 @@
                    (call-with-values
                     (λ () (f argument))
                     (rng-checker f blame neg-party))))
-               (λ (blame f neg-party _ignored-dom-contract _ignored-rng-contract)
+               (λ (blame f neg-party
+                         _ignored-blame-party-info
+                         _ignored-rng-ctcs
+                         _ignored-dom-contract
+                         _ignored-rng-contract)
                  (unless (procedure? f)
                    (raise-blame-error
                     blame #:missing-party neg-party f
diff --git a/racket/collects/racket/contract/private/arrow.rkt b/racket/collects/racket/contract/private/arrow.rkt
index c953a56775..0d9f9dea3a 100644
--- a/racket/collects/racket/contract/private/arrow.rkt
+++ b/racket/collects/racket/contract/private/arrow.rkt
@@ -32,8 +32,9 @@
          (for-syntax check-tail-contract
                      make-this-parameters
                      parse-leftover->*)
-         contract-key
+         tail-contract-key
          tail-marks-match?
+         get-blame-party-info
          values/drop
          arity-checking-wrapper
          unspecified-dom
@@ -49,34 +50,51 @@
       (list id)
       null))
 
-(define contract-key (gensym 'contract-key))
+(define tail-contract-key (gensym 'tail-contract-key))
 
-(define-for-syntax (check-tail-contract rng-ctcs rng-checkers call-gen)
+(define-for-syntax (check-tail-contract rng-ctcs blame-party-info neg-party rng-checkers call-gen)
+  (unless (identifier? rng-ctcs)
+    (raise-argument-error 'check-tail-contract
+                          "identifier?"
+                          0
+                          rng-ctcs rng-checkers call-gen))
   #`(call-with-immediate-continuation-mark
-     contract-key
+     tail-contract-key
      (λ (m)
-       (if (tail-marks-match? m . #,rng-ctcs)
+       (if (tail-marks-match? m #,rng-ctcs #,blame-party-info #,neg-party)
            #,(call-gen #'())
            #,(call-gen rng-checkers)))))
 
-(begin-encourage-inline
- (define tail-marks-match?
-    (case-lambda
-      [(m) (and m (null? m))]
-      [(m rng-ctc)
-       (and m
-            (not (null? m))
-            (null? (cdr m))
-            (procedure-closure-contents-eq? (car m) rng-ctc))]
-      [(m rng-ctc1 rng-ctc2)
-       (and m
-            (= (length m) 2)
-            (procedure-closure-contents-eq? (car m) rng-ctc1)
-            (procedure-closure-contents-eq? (cadr m) rng-ctc1))]
-      [(m . rng-ctcs)
-       (and m
-            (= (length m) (length rng-ctcs))
-            (andmap procedure-closure-contents-eq? m rng-ctcs))])))
+;; m : (or/c #f (cons/c neg-party (cons/c (list/c pos-party boolean?[blame-swapped?]) (listof ctc))))
+;; rng-ctc : (or/c #f (listof ctc))
+;; blame-party-info : (list/c pos-party boolean?[blame-swapped?])
+;; neg-party : neg-party
+(define (tail-marks-match? m rng-ctcs blame-party-info neg-party)
+  (and m
+       rng-ctcs
+       (eq? (car m) neg-party)
+       (let ([mark-blame-part-info (cadr m)])
+         (and (eq? (car mark-blame-part-info) (car blame-party-info))
+              (eq? (cadr mark-blame-part-info) (cadr blame-party-info))))
+       (let loop ([m (cddr m)]
+                  [rng-ctcs rng-ctcs])
+         (cond
+           [(null? m) (null? rng-ctcs)]
+           [(null? rng-ctcs) (null? m)]
+           [else
+            (define m1 (car m))
+            (define rng-ctc1 (car rng-ctcs))
+            (cond
+              [(eq? m1 rng-ctc1) (loop (cdr m) (cdr rng-ctcs))]
+              [(contract-struct-stronger? m1 rng-ctc1) (loop (cdr m) (cdr rng-ctcs))]
+              [else #f])]))))
+
+;; used as part of the information in the continuation mark
+;; that records what is to be checked for a pending contract
+(define (get-blame-party-info blame)
+  (define swapped? (blame-swapped? blame))
+  (list (if swapped? (blame-negative blame) (blame-positive blame))
+        swapped?))
 
 (define-syntax (unconstrained-domain-> stx)
   (syntax-case stx ()
@@ -86,9 +104,11 @@
                    [(p-app-x ...) (generate-temporaries #'(rngs ...))]
                    [(res-x ...) (generate-temporaries #'(rngs ...))])
        #`(let ([rngs-x (coerce-contract 'unconstrained-domain-> rngs)] ...)
-           (let ([proj-x (get/build-late-neg-projection rngs-x)] ...)
+           (let ([rngs-list (list rngs-x ...)]
+                 [proj-x (get/build-late-neg-projection rngs-x)] ...)
              (define (projection wrapper get-ctc)
                (λ (orig-blame)
+                 (define blame-party-info (get-blame-party-info orig-blame))
                  (define ctc (get-ctc))
                  (let ([rng-blame (blame-add-range-context orig-blame)])
                    (let* ([p-app-x (proj-x rng-blame)] ...)
@@ -102,19 +122,23 @@
                            (with-contract-continuation-mark
                             (cons orig-blame neg-party)
                             #,(check-tail-contract
-                               #'(p-app-x ...)
+                               #'rngs-list
+                               #'blame-party-info
+                               #'neg-party
                                (list #'res-checker)
                                (λ (s) #`(apply values #,@s kwd-vals args)))))
                          (λ args
                            (with-contract-continuation-mark
                             (cons orig-blame neg-party)
                             #,(check-tail-contract
-                               #'(p-app-x ...)
+                               #'rngs-list
+                               #'blame-party-info
+                               #'neg-party
                                (list #'res-checker)
                                (λ (s) #`(apply values #,@s args))))))
                         impersonator-prop:contracted ctc
                         impersonator-prop:application-mark
-                        (cons contract-key (list p-app-x ...))))))))
+                        (cons tail-contract-key (list neg-party blame-party-info rngs-x ...))))))))
              (make-unconstrained-domain-> (list rngs-x ...) 
                                           projection))))]))
 
@@ -200,9 +224,9 @@
            (loop (cdr accepted) req-kwds (cdr opt-kwds))]
           [else #f]))])))
 
-(define-for-syntax (create-chaperone blame neg-party val pre post this-args
+(define-for-syntax (create-chaperone blame neg-party blame-party-info val pre post this-args
                                      doms opt-doms dom-rest req-kwds opt-kwds
-                                     rngs)
+                                     rngs rng-ctc-id)
   (with-syntax ([blame blame]
                 [neg-party neg-party]
                 [val val])
@@ -318,7 +342,9 @@
                                                               (dom-ctc dom-x neg-party) ...)))])
                                (if no-rng-checking?
                                    (inner-stx-gen #'())
-                                   (check-tail-contract #'(rng-ctc ...)
+                                   (check-tail-contract rng-ctc-id
+                                                        blame-party-info
+                                                        #'neg-party
                                                         #'(rng-checker-name ...)
                                                         inner-stx-gen)))]
                             [kwd-return
@@ -340,7 +366,11 @@
                                #`(let ([kwd-results kwd-stx])
                                    #,(if no-rng-checking?
                                          (outer-stx-gen #'())
-                                         (check-tail-contract #'(rng-ctc ...) #'(rng-checker-name ...) outer-stx-gen))))])
+                                         (check-tail-contract rng-ctc-id
+                                                              blame-party-info
+                                                              #'neg-party
+                                                              #'(rng-checker-name ...)
+                                                              outer-stx-gen))))])
                 (with-syntax ([basic-lambda-name (gen-id 'basic-lambda)]
                               [basic-lambda #'(λ basic-params
                                                 ;; Arrow contract domain checking is instrumented
@@ -534,7 +564,8 @@
                              (append (base->-doms/c ctc) (list (base->-dom-rest/c ctc)))
                              (base->-doms/c ctc)))]
          [doms-optional-proj (map get/build-late-neg-projection (base->-optional-doms/c ctc))]
-         [rngs-proj (map get/build-late-neg-projection (base->-rngs/c ctc))]
+         [rngs-ctc (base->-rngs/c ctc)]
+         [rngs-proj (map get/build-late-neg-projection rngs-ctc)]
          [mandatory-kwds-proj (map get/build-late-neg-projection (base->-mandatory-kwds/c ctc))]
          [optional-kwds-proj (map get/build-late-neg-projection (base->-optional-kwds/c ctc))]
          [mandatory-keywords (base->-mandatory-kwds ctc)]
@@ -578,16 +609,18 @@
           (kwd-proj (blame-add-context orig-blame
                                        (format "the ~a argument of" kwd)
                                        #:swap? #t))))
-      (define the-args (append partial-doms partial-optional-doms 
-                               partial-mandatory-kwds partial-optional-kwds
-                               partial-ranges))
+      (define the-args (cons rngs-ctc
+                             (append partial-doms partial-optional-doms
+                                     partial-mandatory-kwds partial-optional-kwds
+                                     partial-ranges)))
+      (define blame-party-info (get-blame-party-info orig-blame))
       (λ (val neg-party)
         (if has-rest?
             (check-procedure/more val mtd? dom-length mandatory-keywords optional-keywords
                                   orig-blame neg-party)
             (check-procedure val mtd? dom-length optionals-length mandatory-keywords optional-keywords
                              orig-blame neg-party))
-        (define chap/imp-func (apply func orig-blame neg-party val the-args))
+        (define chap/imp-func (apply func orig-blame neg-party blame-party-info val the-args))
         (if post
             (wrapper
              val
@@ -597,9 +630,8 @@
              val
              chap/imp-func
              impersonator-prop:contracted ctc
-             impersonator-prop:application-mark (cons contract-key 
-                                                      ;; is this right?
-                                                      partial-ranges)))))))
+             impersonator-prop:application-mark
+             (cons tail-contract-key (list* neg-party blame-party-info rngs-ctc))))))))
 
 (define (->-name ctc)
   (single-arrow-name-maker 
@@ -811,19 +843,22 @@
                   [(kwd-ctcs ...) (map (λ (x) (syntax-property x 'racket/contract:negative-position this->))
                                        (syntax->list kwd-ctcs))]
                   [(kwds ...) kwds]
+                  [(rng-ctc-x) (generate-temporaries '(rng-ctc-x))]
                   [use-any? use-any?])
       (with-syntax ([mtd? (and (syntax-parameter-value #'making-a-method) #t)]
                     [->m-ctc? (and (syntax-parameter-value #'method-contract?) #t)]
                     [outer-lambda
-                     #`(lambda (blame neg-party val dom-names ... kwd-names ... rng-names ...)
+                     #`(lambda (blame neg-party blame-party-info val rng-ctc-x
+                                      dom-names ... kwd-names ... rng-names ...)
                          #,(create-chaperone 
-                            #'blame #'neg-party #'val #f #f
+                            #'blame #'neg-party #'blame-party-info #'val #f #f
                             (syntax->list #'(this-params ...))
                             (syntax->list #'(dom-names ...)) null #f
                             (map list (syntax->list #'(kwds ...))
                                  (syntax->list #'(kwd-names ...)))
                             null
-                            (if (syntax->datum #'use-any?) #f (syntax->list #'(rng-names ...)))))])
+                            (if (syntax->datum #'use-any?) #f (syntax->list #'(rng-names ...)))
+                            #'rng-ctc-x))])
         (syntax-property
          (syntax/loc stx
           (build--> '->
@@ -976,6 +1011,7 @@
                              [->m-ctc? (and (syntax-parameter-value #'method-contract?) #t)]
                              [(rng-proj ...) (generate-temporaries (or rng-ctc '()))]
                              [(rng ...) (generate-temporaries (or rng-ctc '()))]
+                             [(rng-ctc-x) (generate-temporaries '(rng-ctc-x))]
                              [(this-parameter ...)
                               (make-this-parameters (car (generate-temporaries '(this))))])
                  (quasisyntax/loc stx
@@ -996,7 +1032,7 @@
                           #''())
                     #,(if rng-ctc #f #t)
                     mtd? ->m-ctc?
-                    (λ (blame neg-party f
+                    (λ (blame neg-party blame-party-info f rng-ctc-x
                         mandatory-dom-proj ...  
                         #,@(if rest-ctc
                                #'(rest-proj)
@@ -1006,7 +1042,7 @@
                         optional-dom-kwd-proj ... 
                         rng-proj ...)
                       #,(create-chaperone 
-                         #'blame #'neg-party #'f pre post
+                         #'blame #'neg-party #'blame-party-info #'f pre post
                          (syntax->list #'(this-parameter ...))
                          (syntax->list #'(mandatory-dom-proj ...))
                          (syntax->list #'(optional-dom-proj ...))
@@ -1015,7 +1051,8 @@
                               (syntax->list #'(mandatory-dom-kwd-proj ...)))
                          (map list (syntax->list #'(optional-dom-kwd ...))
                               (syntax->list #'(optional-dom-kwd-proj ...)))
-                         (if rng-ctc (syntax->list #'(rng-proj ...)) #f)))))))))))]))
+                         (if rng-ctc (syntax->list #'(rng-proj ...)) #f)
+                         #'rng-ctc-x))))))))))]))
 
 (define (convert-pre-post/desc-to-boolean pre? b)
   (cond
diff --git a/racket/collects/racket/contract/private/case-arrow.rkt b/racket/collects/racket/contract/private/case-arrow.rkt
index 83eca5e086..f51e1862ef 100644
--- a/racket/collects/racket/contract/private/case-arrow.rkt
+++ b/racket/collects/racket/contract/private/case-arrow.rkt
@@ -52,27 +52,29 @@
     [_
      (raise-syntax-error #f "expected ->" stx case)]))
 
-(define-for-syntax (parse-out-case stx case n)
-  (let-values ([(doms rst rng) (separate-out-doms/rst/rng stx case)])
-    (with-syntax ([(dom-proj-x  ...) (generate-temporaries doms)]
+(define-for-syntax (parse-out-case stx neg-party blame-party-info case n)
+  (let-values ([(dom-ctc-exprs rst-ctc-expr rng-ctc-exprs) (separate-out-doms/rst/rng stx case)])
+    (with-syntax ([(dom-proj-x  ...) (generate-temporaries dom-ctc-exprs)]
                   [(rst-proj-x) (generate-temporaries '(rest-proj-x))]
-                  [(rng-proj-x ...) (generate-temporaries (if rng rng '()))])
-      (with-syntax ([(dom-formals ...) (generate-temporaries doms)]
+                  [(rng-proj-x ...) (generate-temporaries (if rng-ctc-exprs rng-ctc-exprs '()))]
+                  [(rng-ctcs-x) (generate-temporaries '(rng-ctc-x))])
+      (with-syntax ([(dom-formals ...) (generate-temporaries dom-ctc-exprs)]
                     [(rst-formal) (generate-temporaries '(rest-param))]
-                    [(rng-id ...) (if rng
-                                      (generate-temporaries rng)
+                    [(rng-id ...) (if rng-ctc-exprs
+                                      (generate-temporaries rng-ctc-exprs)
                                       '())]
                     [(this-parameter ...)
                      (make-this-parameters (car (generate-temporaries '(this))))])
-        #`(#,doms
-           #,rst
-           #,(if rng #`(list #,@rng) #f)
-           #,(length (syntax->list doms)) ;; spec
-           (dom-proj-x ... #,@(if rst #'(rst-proj-x) #'()))
+        #`(#,dom-ctc-exprs
+           #,rst-ctc-expr
+           #,(if rng-ctc-exprs #`(list #,@rng-ctc-exprs) #f)
+           #,(length (syntax->list dom-ctc-exprs)) ;; spec
+           (dom-proj-x ... #,@(if rst-ctc-expr #'(rst-proj-x) #'()))
            (rng-proj-x ...)
-           (this-parameter ... dom-formals ... . #,(if rst #'rst-formal '()))
+           rng-ctcs-x
+           (this-parameter ... dom-formals ... . #,(if rst-ctc-expr #'rst-formal '()))
            #,(cond
-               [rng
+               [rng-ctc-exprs
                 (let ([rng-checkers 
                        (list #`(case-lambda
                                  [(rng-id ...) (values/drop (rng-proj-x rng-id neg-party) ...)]
@@ -81,19 +83,21 @@
                                                          #,(length (syntax->list #'(rng-id ...)))
                                                          args
                                                          #,n)]))]
-                      [rng-length (length (syntax->list rng))])
-                  (if rst
-                      (check-tail-contract #'(rng-proj-x ...) rng-checkers
+                      [rng-length (length (syntax->list rng-ctc-exprs))])
+                  (if rst-ctc-expr
+                      (check-tail-contract #'rng-ctcs-x
+                                           blame-party-info neg-party
+                                           rng-checkers
                                            (λ (rng-checks)
                                              #`(apply values #,@rng-checks this-parameter ...
                                                       (dom-proj-x dom-formals neg-party) ...
                                                       (rst-proj-x rst-formal neg-party))))
                       (check-tail-contract
-                       #'(rng-proj-x ...) rng-checkers
+                       #'rng-ctcs-x blame-party-info neg-party rng-checkers
                        (λ (rng-checks)
                          #`(values/drop #,@rng-checks this-parameter ...
                                         (dom-proj-x dom-formals neg-party) ...)))))]
-               [rst
+               [rst-ctc-expr
                 #`(apply values this-parameter ...
                          (dom-proj-x dom-formals neg-party) ...
                          (rst-proj-x rst-formal neg-party))]
@@ -106,30 +110,33 @@
     [(_ cases ...)
      (let ()
        (define name (syntax-local-infer-name stx))
-       (with-syntax ([(((dom-proj ...)
-                        rst-proj
-                        rng-proj
+       (with-syntax ([(((dom-ctc-expr ...)
+                        rst-ctc-expr
+                        rng-ctc-exprs
                         spec
                         (dom-proj-x ...)
                         (rng-proj-x ...)
+                        rng-ctcs-x
                         formals
                         body) ...)
                       (for/list ([x (in-list (syntax->list #'(cases ...)))]
                                  [n (in-naturals)])
-                        (parse-out-case stx x n))]
+                        (parse-out-case stx #'neg-party #'blame-party-info x n))]
                      [mctc? (and (syntax-parameter-value #'method-contract?) #t)])
          #`(syntax-parameterize 
             ((making-a-method #f)) 
             (build-case-> 
-             (list (list dom-proj ...) ...)
-             (list rst-proj ...)
-             (list rng-proj ...)
+             (list (list dom-ctc-expr ...) ...)
+             (list rst-ctc-expr ...)
+             (list rng-ctc-exprs ...)
              '(spec ...)
              mctc?
              (λ (chk
                  wrapper
                  blame
+                 blame-party-info
                  ctc
+                 rng-ctcs-x ...
                  #,@(apply append (map syntax->list (syntax->list #'((dom-proj-x ...) ...))))
                  #,@(apply append (map syntax->list (syntax->list #'((rng-proj-x ...) ...)))))
                (λ (f neg-party)
@@ -139,12 +146,12 @@
                       (if name
                           #`(let ([#,name #,case-lam]) #,name)
                           case-lam))
-                  (list (list rng-proj-x ...) ...)
-                  f blame neg-party wrapper ctc
+                  f blame neg-party blame-party-info wrapper ctc
                   chk #,(and (syntax-parameter-value #'making-a-method) #t))))))))]))
 
-(define (put-it-together the-case-lam range-projections f blame neg-party wrapper ctc chk mtd?)
+(define (put-it-together the-case-lam f blame neg-party blame-party-info wrapper ctc chk mtd?)
   (chk f mtd?)
+  (define rng-ctcs (base-case->-rng-ctcs ctc))
   (define checker
     (make-keyword-procedure
      (raise-no-keywords-error f blame neg-party)
@@ -152,14 +159,15 @@
        (with-contract-continuation-mark
         (cons blame neg-party)
         (apply the-case-lam args)))))
-  (define same-rngs (same-range-projections range-projections))
+  (define same-rngs (same-range-contracts rng-ctcs))
   (if same-rngs
       (wrapper
        f
        checker
        impersonator-prop:contracted ctc
        impersonator-prop:blame (blame-add-missing-party blame neg-party)
-       impersonator-prop:application-mark (cons contract-key same-rngs))
+       impersonator-prop:application-mark
+       (cons tail-contract-key (list* neg-party blame-party-info same-rngs)))
       (wrapper
        f
        checker
@@ -184,13 +192,17 @@
 (define (case->-proj wrapper)
   (λ (ctc)
     (define dom-ctcs+case-nums (get-case->-dom-ctcs+case-nums ctc))
-    (define rng-late-neg-ctcs (map get/build-late-neg-projection (get-case->-rng-ctcs ctc)))
+    (define rng-ctcs (get-case->-rng-ctcs ctc))
+    (define rng-lol-ctcs (base-case->-rng-ctcs ctc))
+    (define rng-late-neg-ctcs (map get/build-late-neg-projection rng-ctcs))
     (define rst-ctcs (base-case->-rst-ctcs ctc))
     (define specs (base-case->-specs ctc))
     (λ (blame)
       (define dom-blame (blame-add-context blame "the domain of" #:swap? #t))
       (define rng-blame (blame-add-context blame "the range of"))
-      (define projs (append (map (λ (f) ((cdr f) 
+      (define blame-party-info (get-blame-party-info blame))
+      (define projs (append rng-lol-ctcs
+                            (map (λ (f) ((cdr f)
                                          (blame-add-context 
                                           (blame-add-context 
                                            blame 
@@ -231,6 +243,7 @@
              chk
              wrapper
              blame
+             blame-party-info
              ctc
              projs))))
 
@@ -303,18 +316,23 @@
 
 (define (get-case->-rng-ctcs ctc)
   (for/fold ([acc '()])
-      ([x (in-list (base-case->-rng-ctcs ctc))]
-       #:when x)
+            ([x (in-list (base-case->-rng-ctcs ctc))]
+             #:when x)
     (append acc x)))
 
 ;; Takes a list of (listof projection), and returns one of the
 ;; lists if all the lists contain the same projections. If the list is
 ;; null, it returns #f.
-(define (same-range-projections rng-ctcss)
-  (if (null? rng-ctcss)
-      #f
-      (let* ([fst (car rng-ctcss)]
-             [all-same? (for/and ([ps (in-list (cdr rng-ctcss))])
-                          (and (= (length fst) (length ps))
-                               (andmap procedure-closure-contents-eq? fst ps)))])
-        (and all-same? fst))))
+(define (same-range-contracts rng-ctcss)
+  (cond
+    [(null? rng-ctcss) #f]
+    [else
+     (define fst (car rng-ctcss))
+     (and (for/and ([ps (in-list (cdr rng-ctcss))])
+            (and ps
+                 (= (length fst) (length ps))
+                 (for/and ([c (in-list ps)]
+                           [fst-c (in-list fst)])
+                   (and (contract-stronger? c fst-c)
+                        (contract-stronger? fst-c c)))))
+          fst)]))
diff --git a/racket/collects/racket/contract/private/opt-guts.rkt b/racket/collects/racket/contract/private/opt-guts.rkt
index aca87b6150..9ac523fe3a 100644
--- a/racket/collects/racket/contract/private/opt-guts.rkt
+++ b/racket/collects/racket/contract/private/opt-guts.rkt
@@ -23,6 +23,7 @@
          opt/info-add-blame-context
          opt/info-change-val
          opt/info-positive-blame
+         opt/info-negative-blame
          
          opt/unknown
          opt-error-name
@@ -164,6 +165,10 @@
   (if (opt/info-swap-blame? oi)
       #`(blame-positive #,(opt/info-blame-original-id oi))
       #`(blame-negative #,(opt/info-blame-original-id oi))))
+(define (opt/info-negative-blame oi)
+  (if (opt/info-swap-blame? oi)
+      #`(blame-negative #,(opt/info-blame-original-id oi))
+      #`(blame-positive #,(opt/info-blame-original-id oi))))
 
 ;; opt/info-swap-blame : opt/info -> opt/info
 ;; swaps pos and neg
diff --git a/racket/collects/racket/contract/private/opters.rkt b/racket/collects/racket/contract/private/opters.rkt
index d1e0104929..64c4e97b25 100644
--- a/racket/collects/racket/contract/private/opters.rkt
+++ b/racket/collects/racket/contract/private/opters.rkt
@@ -576,7 +576,9 @@
            (syntax-case stx ()
              [(x) #'x]
              [(x ...) #'(values x ...)]))
-         #`(let* ([cont-mark-value (cons #,(opt/info-positive-blame opt/info) '#,rngs)]
+         #`(let* ([cont-mark-value (list* #,(opt/info-positive-blame opt/info)
+                                          #,(opt/info-negative-blame opt/info)
+                                          '#,rngs)]
                   [exact-proc (case-lambda
                                 [(dom-arg ...)
                                  (let-values ([(rng-checker dom-vars ...)
diff --git a/racket/collects/racket/contract/private/prop.rkt b/racket/collects/racket/contract/private/prop.rkt
index 4964594e3e..89b2ad36b0 100644
--- a/racket/collects/racket/contract/private/prop.rkt
+++ b/racket/collects/racket/contract/private/prop.rkt
@@ -115,42 +115,50 @@
 
 (define trail (make-parameter #f))
 (define (contract-struct-stronger? a b)
-  (define prop (contract-struct-property a))
-  (define stronger? (contract-property-stronger prop))
   (cond
-    [(let ([th (trail)])
-       (and th
-            (for/or ([(a2 bs-h) (in-hash th)])
-              (and (eq? a a2)
-                   (for/or ([(b2 _) (in-hash bs-h)])
-                     (eq? b b2))))))
-     #t]
-    [(or (prop:recursive-contract? a) (prop:recursive-contract? b))
-     (parameterize ([trail (or (trail) (make-hasheq))])
-       (define trail-h (trail))
-       (let ([a-h (hash-ref trail-h a #f)])
-         (cond
-           [a-h
-            (hash-set! a-h b #t)]
-           [else
-            (define a-h (make-hasheq))
-            (hash-set! trail-h a a-h)
-            (hash-set! a-h b #t)]))
-       (contract-struct-stronger? (if (prop:recursive-contract? a)
-                                      ((prop:recursive-contract-unroll a) a)
-                                      a)
-                                  (if (prop:recursive-contract? b)
-                                      ((prop:recursive-contract-unroll b) b)
-                                      b)))]
+    [(equal? a b) #t]
     [else
-     (let loop ([b b])
-       (cond
-         [(stronger? a b) #t]
-         [(prop:orc-contract? b)
-          (define sub-contracts ((prop:orc-contract-get-subcontracts b) b))
-          (for/or ([sub-contract (in-list sub-contracts)])
-            (loop sub-contract))]
-         [else #f]))]))
+     (define prop (contract-struct-property a))
+     (define stronger? (contract-property-stronger prop))
+     (cond
+       [(stronger? a b)
+        ;; optimistically try skip some of the more complex work below
+        #t]
+       [(let ([th (trail)])
+          (and th
+               (for/or ([(a2 bs-h) (in-hash th)])
+                 (and (eq? a a2)
+                      (for/or ([(b2 _) (in-hash bs-h)])
+                        (eq? b b2))))))
+        #t]
+       [(or (prop:recursive-contract? a) (prop:recursive-contract? b))
+        (parameterize ([trail (or (trail) (make-hasheq))])
+          (define trail-h (trail))
+          (let ([a-h (hash-ref trail-h a #f)])
+            (cond
+              [a-h
+               (hash-set! a-h b #t)]
+              [else
+               (define a-h (make-hasheq))
+               (hash-set! trail-h a a-h)
+               (hash-set! a-h b #t)]))
+          (contract-struct-stronger? (if (prop:recursive-contract? a)
+                                         ((prop:recursive-contract-unroll a) a)
+                                         a)
+                                     (if (prop:recursive-contract? b)
+                                         ((prop:recursive-contract-unroll b) b)
+                                         b)))]
+       [else
+        (let loop ([b b])
+          (cond
+            [(stronger? a b)
+             #t]
+            [(prop:orc-contract? b)
+             (define sub-contracts ((prop:orc-contract-get-subcontracts b) b))
+             (for/or ([sub-contract (in-list sub-contracts)])
+               (loop sub-contract))]
+            [else
+             #f]))])]))
 
 (define (contract-struct-generate c)
   (define prop (contract-struct-property c))