when collapsing use contract-stronger only on trustworthy contracts

pkgs/racket-test/tests/racket/contract/collapsible-vector.rkt

@@ -1452,4 +1452,32 @@
       (define iv (vector-ref cv3 0))
       (vector-set! iv 0 -1))
    "neg1")
+
+  (test/neg-blame
+   'dont-trust-untrustworthy-stronger-implementations
+   '(let ()
+      (define stronger-any/c
+        (make-chaperone-contract #:name 'stronger-any/c
+                                 #:late-neg-projection (lambda (blame)
+                                                         (lambda (val neg-party)
+                                                           val))
+                                 #:stronger (lambda (a b) #t)))
+
+      (define (add-ctcs ctc f)
+        (for/fold ([f f])
+                  ([i (in-range 10)])
+          (contract ctc f 'A 'B #f #f)))
+
+      (define ovec (vector (cons 1 2)))
+
+      (define vec
+        (contract (vector/c pair?)
+                  ovec
+                  'pos 'neg))
+
+      (vector-set! (add-ctcs (vector/c stronger-any/c) vec) 0 "bad value")
+      ;; need to be sure this doesn't return `"bad value"` but the
+      ;; previous line is where the exception gets raised
+      (vector-ref ovec 0)))
+
   )

racket/collects/racket/contract/private/and.rkt

@@ -148,6 +148,7 @@
   #:property prop:custom-write custom-write-property-proc
   #:property prop:flat-contract
   (build-flat-contract-property
+   #:trusted trust-me
    #:late-neg-projection first-order-late-neg-and-proj
    #:name and-name
    #:first-order and-first-order
@@ -158,6 +159,7 @@
   #:property prop:custom-write custom-write-property-proc
   #:property prop:chaperone-contract
   (build-chaperone-contract-property
+   #:trusted trust-me
    #:late-neg-projection late-neg-and-proj
    #:name and-name
    #:first-order and-first-order
@@ -168,6 +170,7 @@
   #:property prop:custom-write custom-write-property-proc
   #:property prop:contract
   (build-contract-property
+   #:trusted trust-me
    #:late-neg-projection late-neg-and-proj
    #:name and-name
    #:first-order and-first-order
@@ -356,6 +359,7 @@
   #:property prop:custom-write custom-write-property-proc
   #:property prop:flat-contract
   (build-flat-contract-property
+   #:trusted trust-me
    #:name integer-in-name
    #:first-order integer-in-first-order
    #:stronger integer-in-stronger
@@ -365,6 +369,7 @@
 (struct renamed-integer-in integer-in-ctc (name)
   #:property prop:flat-contract
   (build-flat-contract-property
+   #:trusted trust-me
    #:name (λ (ctc) (renamed-integer-in-name ctc))
    #:first-order integer-in-first-order
    #:stronger integer-in-stronger

racket/collects/racket/contract/private/arr-d.rkt

@@ -577,6 +577,7 @@
   #:property prop:custom-write custom-write-property-proc
   #:property prop:contract
   (build-contract-property
+   #:trusted trust-me
    #:late-neg-projection (late-neg-->d-proj impersonate-procedure)
    #:name (->d-name #|print-as-method-if-method?|# #t)
    #:first-order ->d-first-order

racket/collects/racket/contract/private/arr-i.rkt

@@ -198,6 +198,7 @@
 (define (mk-prop chaperone?)
   (define c-or-i-procedure (if chaperone? chaperone-procedure impersonate-procedure))
   ((if chaperone? build-chaperone-contract-property build-contract-property)
+   #:trusted trust-me
    #:val-first-projection
    (λ (ctc)
      (define blame-accepting-proj (arr->i-late-neg-proj ctc c-or-i-procedure))

racket/collects/racket/contract/private/arrow-val-first.rkt

@@ -1560,6 +1560,7 @@
                (base->-method? ->stct)
                #t)))
   (build-X-property
+   #:trusted trust-me
    #:name (base->-name #|print-as-method-if-method|# #t)
    #:first-order ->-first-order
    #:projection

racket/collects/racket/contract/private/base.rkt

@@ -324,6 +324,7 @@
   #:property prop:custom-write custom-write-property-proc
   #:property prop:flat-contract
   (build-flat-contract-property
+   #:trusted trust-me
    #:name recursive-contract-name
    #:first-order recursive-contract-first-order
    #:late-neg-projection flat-recursive-contract-late-neg-projection
@@ -335,6 +336,7 @@
   #:property prop:custom-write custom-write-property-proc
   #:property prop:chaperone-contract
   (build-chaperone-contract-property
+   #:trusted trust-me
    #:name recursive-contract-name
    #:first-order recursive-contract-first-order
    #:late-neg-projection recursive-contract-late-neg-projection
@@ -346,6 +348,7 @@
   #:property prop:custom-write custom-write-property-proc
   #:property prop:contract
   (build-contract-property
+   #:trusted trust-me
    #:name recursive-contract-name
    #:first-order recursive-contract-first-order
    #:late-neg-projection recursive-contract-late-neg-projection

racket/collects/racket/contract/private/box.rkt

@@ -135,6 +135,7 @@
   #:property prop:custom-write custom-write-property-proc
   #:property prop:flat-contract
   (build-flat-contract-property
+   #:trusted trust-me
    #:name box/c-name
    #:first-order box/c-first-order
    #:stronger box/c-stronger
@@ -206,6 +207,7 @@
   #:property prop:custom-write custom-write-property-proc
   #:property prop:chaperone-contract
   (build-chaperone-contract-property
+   #:trusted trust-me
    #:name box/c-name
    #:first-order box/c-first-order
    #:stronger box/c-stronger
@@ -216,6 +218,7 @@
   #:property prop:custom-write custom-write-property-proc
   #:property prop:contract
   (build-contract-property
+   #:trusted trust-me
    #:name box/c-name
    #:first-order box/c-first-order
    #:stronger box/c-stronger

racket/collects/racket/contract/private/case-arrow.rkt

@@ -289,6 +289,7 @@
   #:property prop:custom-write custom-write-property-proc
   #:property prop:chaperone-contract
   (build-chaperone-contract-property
+   #:trusted trust-me
    #:late-neg-projection (case->-proj chaperone-procedure)
    #:name (case->-name #|print-as-method-if-method?|# #t)
    #:first-order case->-first-order
@@ -298,6 +299,7 @@
   #:property prop:custom-write custom-write-property-proc
   #:property prop:contract
   (build-contract-property
+   #:trusted trust-me
    #:late-neg-projection (case->-proj impersonate-procedure)
    #:name (case->-name #|print-as-method-if-method?|# #t)
    #:first-order case->-first-order

racket/collects/racket/contract/private/collapsible-common.rkt

@@ -143,7 +143,7 @@
        (for/or ([old-ctc (in-list contract-list)])
          (and old-ctc
               (flat-contract-struct? new-ctc)
-              (contract-struct-stronger? old-ctc new-ctc)))))
+              (trusted-contract-struct-stronger? old-ctc new-ctc)))))
 
 ;; join two collapsible-leaf contracts
 (define (join-collapsible-leaf/c new-collapsible new-neg old-collapsible old-neg)

racket/collects/racket/contract/private/ds.rkt

@@ -320,6 +320,7 @@ it around flattened out.
           
           (define lazy-contract-property
             (build-contract-property
+             #:trusted trust-me
              #:projection lazy-contract-proj
              #:name lazy-contract-name
              #:first-order (lambda (ctc) predicate)

racket/collects/racket/contract/private/exists.rkt

@@ -32,6 +32,7 @@
   #:property prop:custom-write custom-write-property-proc  
   #:property prop:contract
   (build-contract-property
+   #:trusted trust-me
    #:name (λ (ctc) (∀∃/c-name ctc))
    #:first-order (λ (ctc) (λ (x) #t)) ;; ???
    #:late-neg-projection ∀∃-late-neg-proj

racket/collects/racket/contract/private/guts.rkt

@@ -577,6 +577,7 @@
   #:property prop:custom-write contract-custom-write-property-proc
   #:property prop:flat-contract
   (build-flat-contract-property
+   #:trusted trust-me
    #:first-order (λ (ctc) (λ (x) (eq? (eq-contract-val ctc) x)))
    #:name (λ (ctc) (eq-contract-name ctc))
    #:generate
@@ -605,6 +606,7 @@
   #:property prop:custom-write contract-custom-write-property-proc
   #:property prop:flat-contract
   (build-flat-contract-property
+   #:trusted trust-me
    #:first-order (λ (ctc) (λ (x) (equal? (equal-contract-val ctc) x)))
    #:name (λ (ctc) (equal-contract-name ctc))
    #:stronger
@@ -629,6 +631,7 @@
   #:property prop:custom-write contract-custom-write-property-proc
   #:property prop:flat-contract
   (build-flat-contract-property
+   #:trusted trust-me
    #:first-order (λ (ctc) (λ (x) (and (number? x) (= (=-contract-val ctc) x))))
    #:name (λ (ctc) (=-contract-name ctc))
    #:stronger
@@ -686,6 +689,7 @@
   #:property prop:custom-write contract-custom-write-property-proc
   #:property prop:flat-contract
   (build-flat-contract-property
+   #:trusted trust-me
    #:first-order
    (λ (ctc)
      (define low (char-in/c-low ctc))
@@ -738,6 +742,7 @@
   #:property prop:custom-write contract-custom-write-property-proc
   #:property prop:flat-contract
   (build-flat-contract-property
+   #:trusted trust-me
    #:first-order
    (λ (ctc)
      (define reg (regexp/c-reg ctc))
@@ -759,6 +764,7 @@
   #:property prop:custom-write contract-custom-write-property-proc
   #:property prop:flat-contract
   (build-flat-contract-property
+   #:trusted trust-me
    #:stronger predicate-contract-equivalent
    #:equivalent predicate-contract-equivalent
    #:name (λ (ctc) (predicate-contract-name ctc))

racket/collects/racket/contract/private/hash.rkt

@@ -241,6 +241,7 @@
   #:property prop:custom-write custom-write-property-proc
   #:property prop:flat-contract
   (build-flat-contract-property
+   #:trusted trust-me
    #:name hash/c-name
    #:first-order hash/c-first-order
    #:generate hash/c-generate
@@ -359,6 +360,7 @@
   #:property prop:custom-write custom-write-property-proc
   #:property prop:chaperone-contract
   (build-chaperone-contract-property
+   #:trusted trust-me
    #:name hash/c-name
    #:first-order hash/c-first-order
    #:generate hash/c-generate
@@ -372,6 +374,7 @@
   #:property prop:custom-write custom-write-property-proc
   #:property prop:contract
   (build-contract-property
+   #:trusted trust-me
    #:name hash/c-name
    #:first-order hash/c-first-order
    #:stronger hash/c-stronger
@@ -437,6 +440,7 @@
   #:property prop:custom-write custom-write-property-proc
   #:property prop:flat-contract
   (build-flat-contract-property
+   #:trusted trust-me
    #:name hash/dc-name
    #:first-order hash/dc-first-order
    #:equivalent hash/dc-equivalent
@@ -446,6 +450,7 @@
   #:property prop:custom-write custom-write-property-proc
   #:property prop:chaperone-contract
   (build-chaperone-contract-property
+   #:trusted trust-me
    #:name hash/dc-name
    #:first-order hash/dc-first-order
    #:stronger hash/dc-stronger
@@ -455,6 +460,7 @@
   #:property prop:custom-write custom-write-property-proc
   #:property prop:contract
   (build-contract-property
+   #:trusted trust-me
    #:name hash/dc-name
    #:first-order hash/dc-first-order
    #:stronger hash/dc-stronger

racket/collects/racket/contract/private/list.rkt

@@ -235,6 +235,7 @@
 
 (define flat-prop
   (build-flat-contract-property
+   #:trusted trust-me
    #:name list-name
    #:first-order list-fo-check
    #:late-neg-projection listof-late-neg-projection
@@ -245,6 +246,7 @@
    #:list-contract? (λ (c) (not (im-listof-ctc? c)))))
 (define chap-prop
   (build-chaperone-contract-property
+   #:trusted trust-me
    #:name list-name
    #:first-order list-fo-check
    #:late-neg-projection listof-late-neg-projection
@@ -255,6 +257,7 @@
    #:list-contract? (λ (c) (not (im-listof-ctc? c)))))
 (define full-prop
   (build-contract-property
+   #:trusted trust-me
    #:name list-name
    #:first-order list-fo-check
    #:late-neg-projection listof-late-neg-projection
@@ -440,6 +443,7 @@
   #:property prop:custom-write custom-write-property-proc
   #:property prop:flat-contract
   (build-flat-contract-property
+   #:trusted trust-me
    #:late-neg-projection (cons/c-late-neg-ho-check (λ (v a d) v))
    #:name cons/c-name
    #:first-order cons/c-first-order
@@ -451,6 +455,7 @@
   #:property prop:custom-write custom-write-property-proc
   #:property prop:chaperone-contract
   (build-chaperone-contract-property
+   #:trusted trust-me
    #:late-neg-projection (cons/c-late-neg-ho-check (λ (v a d) (cons a d)))
    #:name cons/c-name
    #:first-order cons/c-first-order
@@ -462,6 +467,7 @@
   #:property prop:custom-write custom-write-property-proc
   #:property prop:contract
   (build-contract-property
+   #:trusted trust-me
    #:late-neg-projection (cons/c-late-neg-ho-check (λ (v a d) (cons a d)))
    #:name cons/c-name
    #:first-order cons/c-first-order
@@ -565,6 +571,7 @@
   #:property prop:custom-write custom-write-property-proc
   #:property prop:flat-contract
   (build-flat-contract-property
+   #:trusted trust-me
    #:late-neg-projection cons/dc-late-neg-projection
    #:name cons/dc-name
    #:first-order cons/dc-first-order
@@ -576,6 +583,7 @@
   #:property prop:custom-write custom-write-property-proc
   #:property prop:chaperone-contract
   (build-chaperone-contract-property
+   #:trusted trust-me
    #:late-neg-projection cons/dc-late-neg-projection
    #:name cons/dc-name
    #:first-order cons/dc-first-order
@@ -587,6 +595,7 @@
   #:property prop:custom-write custom-write-property-proc
   #:property prop:contract
   (build-contract-property
+   #:trusted trust-me
    #:late-neg-projection cons/dc-late-neg-projection
    #:name cons/dc-name
    #:first-order cons/dc-first-order
@@ -728,6 +737,7 @@
   #:property prop:custom-write custom-write-property-proc
   #:property prop:flat-contract
   (build-flat-contract-property
+   #:trusted trust-me
    #:name list/c-name-proc
    #:first-order list/c-first-order
    #:generate list/c-generate
@@ -817,6 +827,7 @@
   #:property prop:custom-write custom-write-property-proc
   #:property prop:chaperone-contract
   (build-chaperone-contract-property
+   #:trusted trust-me
    #:name list/c-name-proc
    #:first-order list/c-first-order
    #:generate list/c-generate
@@ -830,6 +841,7 @@
   #:property prop:custom-write custom-write-property-proc
   #:property prop:contract
   (build-contract-property
+   #:trusted trust-me
    #:name list/c-name-proc
    #:first-order list/c-first-order
    #:generate list/c-generate
@@ -1015,6 +1027,7 @@
 (struct flat-*list/c *list-ctc ()
   #:property prop:contract
   (build-contract-property
+   #:trusted trust-me
    #:name *list/c-name-proc
    #:first-order *list/c-first-order
    #:generate *list/c-generate
@@ -1026,6 +1039,7 @@
 (struct chaperone-*list/c *list-ctc ()
   #:property prop:contract
   (build-contract-property
+   #:trusted trust-me
    #:name *list/c-name-proc
    #:first-order *list/c-first-order
    #:generate *list/c-generate
@@ -1037,6 +1051,7 @@
 (struct impersonator-*list/c *list-ctc ()
   #:property prop:contract
   (build-contract-property
+   #:trusted trust-me
    #:name *list/c-name-proc
    #:first-order *list/c-first-order
    #:generate *list/c-generate
@@ -1081,6 +1096,7 @@
 (struct flat-ellipsis-rest-arg ellipsis-rest-arg-ctc ()
   #:property prop:contract
   (build-contract-property
+   #:trusted trust-me
    #:name (λ (ctc) (error 'flat-ellipsis-rest-arg "the name property shouldn't be called!"))
    #:first-order *list/c-first-order
    #:generate *list/c-generate
@@ -1093,6 +1109,7 @@
 (struct chaperone-ellipsis-rest-arg ellipsis-rest-arg-ctc ()
   #:property prop:contract
   (build-contract-property
+   #:trusted trust-me
    #:name (λ (ctc) (error 'flat-ellipsis-rest-arg "the name property shouldn't be called!"))
    #:first-order *list/c-first-order
    #:generate *list/c-generate
@@ -1105,6 +1122,7 @@
 (struct impersonator-ellipsis-rest-arg ellipsis-rest-arg-ctc ()
   #:property prop:contract
   (build-contract-property
+   #:trusted trust-me
    #:name (λ (ctc) (error 'flat-ellipsis-rest-arg "the name property shouldn't be called!"))
    #:first-order *list/c-first-order
    #:generate *list/c-generate

racket/collects/racket/contract/private/misc.rkt

@@ -191,6 +191,7 @@
   #:property prop:custom-write custom-write-property-proc
   #:property prop:flat-contract
   (build-flat-contract-property
+   #:trusted trust-me
    #:name
    (λ (ctc)
      (cond
@@ -236,6 +237,7 @@
 
 (define (make-</c->/c-contract-property name </> -/+ less/greater)
   (build-flat-contract-property
+   #:trusted trust-me
    #:name (λ (c)
             (cond
               [(renamed-<-ctc? c) (renamed-<-ctc-name c)]
@@ -378,6 +380,7 @@
   #:property prop:custom-write custom-write-property-proc
   #:property prop:flat-contract
   (build-flat-contract-property
+   #:trusted trust-me
    #:name (λ (ctc) (build-compound-type-name 'syntax/c (syntax-ctc-ctc ctc)))
    #:stronger (λ (this that)
                 (and (syntax-ctc? that)
@@ -472,6 +475,7 @@
   #:property prop:custom-write custom-write-property-proc
   #:property prop:chaperone-contract
   (build-chaperone-contract-property
+   #:trusted trust-me
    #:name promise-contract-name
    #:late-neg-projection promise-contract-late-neg-proj
    #:stronger promise-ctc-stronger?
@@ -482,6 +486,7 @@
   #:property prop:custom-write custom-write-property-proc
   #:property prop:contract
   (build-contract-property
+   #:trusted trust-me
    #:name promise-contract-name
    #:late-neg-projection promise-contract-late-neg-proj
    #:stronger promise-ctc-stronger?
@@ -508,6 +513,7 @@
   #:omit-define-syntaxes
   #:property prop:contract
   (build-contract-property
+   #:trusted trust-me
    #:late-neg-projection
    (λ (ctc)
      (define in-proc (get/build-late-neg-projection (parameter/c-in ctc)))
@@ -571,6 +577,7 @@
   #:omit-define-syntaxes
   #:property prop:flat-contract
   (build-flat-contract-property
+   #:trusted trust-me
    #:stronger procedure-arity-includes-equivalent?
    #:equivalent procedure-arity-includes-equivalent?
    #:name (λ (ctc) `(procedure-arity-includes/c ,(procedure-arity-includes/c-n ctc)))
@@ -648,6 +655,7 @@
   #:property prop:any/c #f
   #:property prop:flat-contract
   (build-flat-contract-property
+   #:trusted trust-me
    #:late-neg-projection (λ (ctc) any/c-blame->neg-party-fn)
    #:stronger (λ (this that) (any/c? that))
    #:equivalent (λ (this that) (any/c? that))
@@ -676,6 +684,7 @@
   #:omit-define-syntaxes
   #:property prop:flat-contract
   (build-flat-contract-property
+   #:trusted trust-me
    #:late-neg-projection none-curried-late-neg-proj
    #:stronger (λ (this that) #t)
    #:equivalent (λ (this that) (none/c? that))
@@ -784,6 +793,7 @@
   #:property prop:custom-write custom-write-property-proc
   #:property prop:chaperone-contract
   (build-chaperone-contract-property
+   #:trusted trust-me
    #:late-neg-projection (prompt-tag/c-late-neg-proj #t)
    #:first-order (λ (ctc) continuation-prompt-tag?)
    #:stronger prompt-tag/c-stronger?
@@ -794,6 +804,7 @@
   #:property prop:custom-write custom-write-property-proc
   #:property prop:contract
   (build-contract-property
+   #:trusted trust-me
    #:late-neg-projection (prompt-tag/c-late-neg-proj #f)
    #:first-order (λ (ctc) continuation-prompt-tag?)
    #:stronger prompt-tag/c-stronger?
@@ -863,6 +874,7 @@
   #:property prop:custom-write custom-write-property-proc
   #:property prop:chaperone-contract
   (build-chaperone-contract-property
+   #:trusted trust-me
    #:late-neg-projection (continuation-mark-key/c-late-neg-proj chaperone-continuation-mark-key)
    #:first-order (λ (ctc) continuation-mark-key?)
    #:stronger continuation-mark-key/c-stronger?
@@ -875,6 +887,7 @@
   #:property prop:custom-write custom-write-property-proc
   #:property prop:contract
   (build-contract-property
+   #:trusted trust-me
    #:late-neg-projection (continuation-mark-key/c-late-neg-proj impersonate-continuation-mark-key)
    #:first-order (λ (ctc) continuation-mark-key?)
    #:stronger continuation-mark-key/c-stronger?
@@ -956,6 +969,7 @@
 (define-struct chaperone-evt/c (ctcs)
   #:property prop:chaperone-contract
   (build-chaperone-contract-property
+   #:trusted trust-me
    #:late-neg-projection evt/c-proj
    #:first-order evt/c-first-order
    #:stronger evt/c-stronger?
@@ -1030,6 +1044,7 @@
   #:property prop:custom-write custom-write-property-proc
   #:property prop:chaperone-contract
   (build-chaperone-contract-property
+   #:trusted trust-me
    #:late-neg-projection (channel/c-late-neg-proj chaperone-channel)
    #:first-order channel/c-first-order
    #:stronger channel/c-stronger?
@@ -1041,6 +1056,7 @@
   #:property prop:custom-write custom-write-property-proc
   #:property prop:contract
   (build-contract-property
+   #:trusted trust-me
    #:late-neg-projection (channel/c-late-neg-proj impersonate-channel)
    #:first-order channel/c-first-order
    #:stronger channel/c-stronger?
@@ -1178,6 +1194,7 @@
 (define-struct (chaperone-if/c base-if/c) ()
   #:property prop:chaperone-contract
   (build-chaperone-contract-property
+   #:trusted trust-me
    #:late-neg-projection if/c-late-neg-proj
    #:first-order if/c-first-order
    #:name if/c-name))
@@ -1185,6 +1202,7 @@
 (define-struct (impersonator-if/c base-if/c) ()
   #:property prop:contract
   (build-contract-property
+   #:trusted trust-me
    #:late-neg-projection if/c-late-neg-proj
    #:first-order if/c-first-order
    #:name if/c-name))

racket/collects/racket/contract/private/object.rkt

@@ -57,6 +57,7 @@
   #:omit-define-syntaxes
   #:property prop:contract
   (build-contract-property
+   #:trusted trust-me
    #:late-neg-projection
    (λ (ctc)
      (define flds (object-contract-fields ctc))
@@ -122,6 +123,7 @@
   #:property prop:custom-write custom-write-property-proc
   #:property prop:flat-contract
   (build-flat-contract-property
+   #:trusted trust-me
    #:first-order (λ (ctc) (define % (subclass/c-% ctc)) (λ (x) (subclass? x %)))
    #:stronger (λ (this that)
                 (cond
@@ -141,6 +143,7 @@
   #:property prop:custom-write custom-write-property-proc
   #:property prop:flat-contract
   (build-flat-contract-property
+   #:trusted trust-me
    #:first-order (λ (ctc) (define <%> (implementation/c-<%> ctc)) (λ (x) (implementation? x <%>)))
    #:stronger (λ (this that)
                 (cond
@@ -173,6 +176,7 @@
   #:property prop:custom-write custom-write-property-proc
   #:property prop:flat-contract
   (build-flat-contract-property
+   #:trusted trust-me
    #:first-order
    (λ (ctc)
      (define <%> (is-a?-ctc-<%> ctc))
@@ -249,4 +253,3 @@
      'is-a?/c
      (format "~s" '(or/c interface? class?))
      <%>)))
-  

racket/collects/racket/contract/private/opt.rkt

@@ -379,6 +379,7 @@
   (λ (val port mode) (fprintf port "#<opt-flat-contract: ~.s>" (opt-contract-name val)))
   #:property prop:flat-contract
   (build-flat-contract-property
+   #:trusted trust-me
    #:projection (λ (ctc) ((opt-contract-proj ctc) ctc))
    #:first-order (λ (ctc) (flat-opt-contract-predicate ctc))
    #:name (λ (ctc) (opt-contract-name ctc))

racket/collects/racket/contract/private/orc.rkt

@@ -228,6 +228,7 @@
   #:property prop:custom-write custom-write-property-proc
   #:property prop:chaperone-contract
   (build-chaperone-contract-property
+   #:trusted trust-me
    #:late-neg-projection single-or/c-late-neg-projection
    #:name single-or/c-name
    #:first-order single-or/c-first-order
@@ -243,6 +244,7 @@
   #:property prop:custom-write custom-write-property-proc
   #:property prop:contract
   (build-contract-property
+   #:trusted trust-me
    #:late-neg-projection single-or/c-late-neg-projection
    #:name single-or/c-name
    #:first-order single-or/c-first-order
@@ -358,6 +360,7 @@
   #:property prop:custom-write custom-write-property-proc
   #:property prop:chaperone-contract
   (build-chaperone-contract-property
+   #:trusted trust-me
    #:late-neg-projection multi-or/c-late-neg-proj
    #:name multi-or/c-name
    #:first-order multi-or/c-first-order
@@ -373,6 +376,7 @@
   #:property prop:custom-write custom-write-property-proc
   #:property prop:contract
   (build-contract-property
+   #:trusted trust-me
    #:late-neg-projection multi-or/c-late-neg-proj
    #:name multi-or/c-name
    #:first-order multi-or/c-first-order
@@ -390,6 +394,7 @@
   (λ (this) (flat-or/c-flat-ctcs this))
   #:property prop:flat-contract
   (build-flat-contract-property
+   #:trusted trust-me
    #:name
    (λ (ctc)
       (apply build-compound-type-name 
@@ -495,6 +500,7 @@
 (define-struct (chaperone-first-or/c base-first-or/c) ()
   #:property prop:chaperone-contract
   (build-chaperone-contract-property
+   #:trusted trust-me
    #:late-neg-projection first-or/c-late-neg-proj
    #:name first-or/c-name
    #:first-order first-or/c-first-order
@@ -506,6 +512,7 @@
 (define-struct (impersonator-first-or/c base-first-or/c) ()
   #:property prop:contract
   (build-contract-property
+   #:trusted trust-me
    #:late-neg-projection first-or/c-late-neg-proj
    #:name first-or/c-name
    #:first-order first-or/c-first-order
@@ -546,6 +553,7 @@
   #:property prop:custom-write custom-write-property-proc
   #:property prop:flat-contract
   (build-flat-contract-property
+   #:trusted trust-me
    #:name
    (λ (ctc) (flat-rec-contract-name ctc))
    #:stronger

racket/collects/racket/contract/private/parametric.rkt

@@ -32,6 +32,7 @@
   #:property prop:custom-write custom-write-property-proc
   #:property prop:contract
   (build-contract-property
+   #:trusted trust-me
    #:name
    (lambda (c)
      `(parametric->/c ,(polymorphic-contract-vars c) ,(polymorphic-contract-body-src-exp c)))
@@ -119,6 +120,7 @@
   #:property prop:custom-write custom-write-property-proc
   #:property prop:contract
   (build-contract-property
+   #:trusted trust-me
    #:name (lambda (c) (barrier-contract-name c))
    #:first-order (λ (c) (barrier-contract-pred c))
    #:stronger (λ (this that) (eq? this that))

racket/collects/racket/contract/private/prop.rkt

@@ -13,6 +13,8 @@
          contract-struct-late-neg-projection
          contract-struct-collapsible-late-neg-projection
          contract-struct-stronger?
+         trusted-contract-struct?
+         trusted-contract-struct-stronger?
          contract-struct-equivalent?
          contract-struct-generate
          contract-struct-exercise
@@ -52,7 +54,9 @@
 
          prop:any/c prop:any/c?
          
-         build-context)
+         build-context
+
+         (protect-out trust-me))
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;;
@@ -70,8 +74,8 @@
                                    val-first-projection
                                    late-neg-projection
                                    collapsible-late-neg-projection
-                                   list-contract? ]
-  #:omit-define-syntaxes)
+                                   list-contract? ])
+(define-struct (trusted-contract-property contract-property) ())
 
 (define (contract-property-guard prop info)
   (unless (contract-property? prop)
@@ -86,6 +90,11 @@
 (define-values [ prop:contract contract-struct? contract-struct-property ]
   (make-struct-type-property 'prop:contract contract-property-guard))
 
+;; determines if `c` is a contract that is trusted
+(define (trusted-contract-struct? c)
+  (and (contract-struct? c)
+       (trusted-contract-property? (contract-struct-property c))))
+
 (define (contract-struct-name c)
   (let* ([prop (contract-struct-property c)]
          [get-name (contract-property-name prop)]
@@ -121,6 +130,7 @@
   (and get-collapsible-projection
        (get-collapsible-projection c)))
 
+(define only-trusted? (make-parameter #f))
 (define (contract-struct-stronger/equivalent?
          a b
          trail
@@ -132,6 +142,9 @@
                 (chaperone-contract-struct? a))
             (equal? a b))
        #t]
+      [(and (only-trusted?)
+            (not (trusted-contract-struct? a)))
+       #f]
       [else
        (define prop (contract-struct-property a))
        (define stronger/equivalent? (contract-property-stronger/equivalent prop))
@@ -193,6 +206,12 @@
    contract-property-stronger
    #t))
 
+;; determines if `a` is stronger than `b` but using
+;; the contract-stronger method only on trusted contracts
+(define (trusted-contract-struct-stronger? a b)
+  (parameterize ([only-trusted? #t])
+    (contract-struct-stronger? a b)))
+
 (define equivalent-trail (make-parameter #f))
 (define (contract-struct-equivalent? a b)
   (contract-struct-stronger/equivalent?
@@ -298,7 +317,7 @@
 
 (define-logger racket/contract)
 
-(define ((build-property mk default-name proc-name first-order? equivalent-equal?)
+(define ((build-property mk trusted-mk default-name proc-name first-order? equivalent-equal?)
          #:name [get-name #f]
          #:first-order [get-first-order #f]
          #:projection [get-projection #f]
@@ -309,7 +328,8 @@
          #:equivalent [equivalent #f]
          #:generate [generate (λ (ctc) (λ (fuel) #f))]
          #:exercise [exercise (λ (ctc) (λ (fuel) (values void '())))]
-         #:list-contract? [list-contract? (λ (c) #f)])
+         #:list-contract? [list-contract? (λ (c) #f)]
+         #:trusted [trusted #f])
   (unless (or get-first-order
               get-projection
               get-val-first-projection
@@ -340,7 +360,8 @@
             "  in the #:list-contract? argument")
            list-contract?))
 
-  (mk (or get-name (λ (c) default-name))
+  ((if (equal? trusted trust-me) trusted-mk mk)
+   (or get-name (λ (c) default-name))
       (or get-first-order get-any?)
       get-projection
       (or stronger weakest)
@@ -358,6 +379,8 @@
       get-collapsible-late-neg-projection
       list-contract?))
 
+(define trust-me (gensym 'trustme))
+
 (define (build-context)
   (apply
    string-append
@@ -367,18 +390,21 @@
     
 (define build-contract-property
   (procedure-rename
-   (build-property make-contract-property 'anonymous-contract 'build-contract-property #f #f)
+   (build-property make-contract-property make-trusted-contract-property
+                   'anonymous-contract 'build-contract-property #f #f)
    'build-contract-property))
 
 (define build-flat-contract-property
   (procedure-rename
    (build-property (compose make-flat-contract-property make-contract-property)
+                   (compose make-flat-contract-property make-trusted-contract-property)
                    'anonymous-flat-contract 'build-flat-contract-property #t #t)
    'build-flat-contract-property))
 
 (define build-chaperone-contract-property
   (procedure-rename
    (build-property (compose make-chaperone-contract-property make-contract-property)
+                   (compose make-chaperone-contract-property make-trusted-contract-property)
                    'anonymous-chaperone-contract 'build-chaperone-contract-property #f #t)
    'build-chaperone-contract-property))
 

racket/collects/racket/contract/private/struct-dc.rkt

@@ -733,6 +733,7 @@
 (define-struct (struct/dc base-struct/dc) ()
   #:property prop:chaperone-contract
   (build-chaperone-contract-property
+   #:trusted trust-me
    #:name struct/dc-name
    #:first-order struct/dc-first-order
    #:late-neg-projection struct/dc-late-neg-proj
@@ -744,6 +745,7 @@
 (define-struct (flat-struct/dc base-struct/dc) ()
   #:property prop:flat-contract
   (build-flat-contract-property
+   #:trusted trust-me
    #:name struct/dc-name
    #:first-order struct/dc-flat-first-order
    #:late-neg-projection struct/dc-late-neg-proj
@@ -755,6 +757,7 @@
 (define-struct (impersonator-struct/dc base-struct/dc) ()
   #:property prop:contract
   (build-contract-property
+   #:trusted trust-me
    #:name struct/dc-name
    #:first-order struct/dc-first-order
    #:late-neg-projection struct/dc-late-neg-proj

racket/collects/racket/contract/private/struct-prop.rkt

@@ -38,6 +38,7 @@
   #:property prop:custom-write custom-write-property-proc
   #:property prop:contract
              (build-contract-property
+              #:trusted trust-me
               #:name (lambda (c)
                        (build-compound-type-name
                         'struct-type-property/c

racket/collects/racket/contract/private/unconstrained-domain-arrow.rkt

@@ -112,6 +112,7 @@
   #:property
   prop:chaperone-contract
   (build-chaperone-contract-property
+   #:trusted trust-me
    #:name unconstrained-domain->-name
    #:first-order unconstrained-domain->-first-order
    #:late-neg-projection unconstrained-domain->-projection
@@ -121,6 +122,7 @@
   #:property
   prop:chaperone-contract
   (build-chaperone-contract-property
+   #:trusted trust-me
    #:name unconstrained-domain->-name
    #:first-order unconstrained-domain->-first-order
    #:late-neg-projection unconstrained-domain->-projection

racket/collects/racket/contract/private/vector.rkt

@@ -134,6 +134,7 @@
   #:property prop:custom-write custom-write-property-proc
   #:property prop:flat-contract
   (build-flat-contract-property
+   #:trusted trust-me
    #:name vectorof-name
    #:first-order vectorof-first-order
    #:late-neg-projection (λ (ctc) 
@@ -315,6 +316,7 @@
   #:property prop:custom-write custom-write-property-proc
   #:property prop:chaperone-contract
   (build-chaperone-contract-property
+   #:trusted trust-me
    #:name vectorof-name
    #:first-order vectorof-first-order
    #:equivalent vectorof-equivalent
@@ -325,6 +327,7 @@
   #:property prop:custom-write custom-write-property-proc
   #:property prop:contract
   (build-contract-property
+   #:trusted trust-me
    #:name vectorof-name
    #:first-order vectorof-first-order
    #:equivalent vectorof-equivalent
@@ -458,6 +461,7 @@
   #:property prop:custom-write custom-write-property-proc
   #:property prop:flat-contract
   (build-flat-contract-property
+   #:trusted trust-me
    #:name vector/c-name
    #:first-order vector/c-first-order
    #:stronger vector/c-stronger
@@ -646,6 +650,7 @@
   #:property prop:custom-write custom-write-property-proc
   #:property prop:chaperone-contract
   (build-chaperone-contract-property
+   #:trusted trust-me
    #:name vector/c-name
    #:first-order vector/c-first-order
    #:stronger vector/c-stronger
@@ -656,6 +661,7 @@
   #:property prop:custom-write custom-write-property-proc
   #:property prop:contract
   (build-contract-property
+   #:trusted trust-me
    #:name vector/c-name
    #:first-order vector/c-first-order
    #:stronger vector/c-stronger

racket/collects/racket/private/class-c-old.rkt

@@ -9,6 +9,7 @@
          "../contract/base.rkt"
          "../contract/combinator.rkt"
          (only-in "../contract/private/arrow-val-first.rkt" ->-internal ->*-internal)
+         (only-in "../contract/private/prop.rkt" trust-me)
          (only-in "../contract/private/case-arrow.rkt" case->-internal)
          (only-in "../contract/private/arr-d.rkt" ->d-internal)
          (submod "../contract/private/collapsible-common.rkt" properties))
@@ -1083,6 +1084,7 @@
   #:property prop:custom-write custom-write-property-proc
   #:property prop:contract
   (build-contract-property
+   #:trusted trust-me
    #:late-neg-projection class/c-late-neg-proj
    #:name build-class/c-name
    #:stronger class/c-stronger
@@ -1522,7 +1524,8 @@
 (define-struct base-instanceof/c (class-ctc)
   #:property prop:custom-write custom-write-property-proc
   #:property prop:contract
-  (build-contract-property 
+  (build-contract-property
+   #:trusted trust-me
    #:late-neg-projection instanceof/c-late-neg-proj
    #:name
    (λ (ctc)
@@ -1660,6 +1663,7 @@
   #:property prop:custom-write custom-write-property-proc
   #:property prop:contract
   (build-contract-property
+   #:trusted trust-me
    #:late-neg-projection instanceof/c-late-neg-proj
    #:name
    (λ (ctc)