Add a missing property to an expression lifted by the contract system.

Caused TR to miss it.

racket/collects/racket/contract/base.rkt

@@ -43,7 +43,8 @@
                "private/struct-dc.rkt"
                "private/struct-prop.rkt")
  (except-out (all-from-out "private/base.rkt")
-             current-contract-region)
+             current-contract-region
+             (for-syntax lifted-key add-lifted-property))
  (except-out (all-from-out "private/misc.rkt")
              check-between/c
              check-unary-between/c

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

@@ -3,7 +3,8 @@
 (provide contract
          (rename-out [-recursive-contract recursive-contract])
          current-contract-region
-         invariant-assertion)
+         invariant-assertion
+         (for-syntax lifted-key add-lifted-property))
 
 (require (for-syntax racket/base syntax/name syntax/srcloc)
          racket/stxparam
@@ -17,6 +18,13 @@
          "generate.rkt"
          )
 
+(begin-for-syntax
+ (define lifted-key (gensym 'contract:lifted))
+ ;; syntax? -> syntax?
+ ;; tells clients that the expression is a lifted application
+ (define (add-lifted-property stx)
+   (syntax-property stx lifted-key #t)))
+
 (define-for-syntax lifted-ccrs (make-hasheq))
 
 (define-syntax-parameter current-contract-region
@@ -26,7 +34,8 @@
                 [id (hash-ref lifted-ccrs ctxt #f)])
            (with-syntax ([id (or id
                                  (let ([id (syntax-local-lift-expression 
-                                            (syntax/loc stx (quote-module-name)))])
+                                            (add-lifted-property
+                                             (syntax/loc stx (quote-module-name))))])
                                    (hash-set! lifted-ccrs ctxt (syntax-local-introduce id))
                                    id))])
              #'id))

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

@@ -3,6 +3,7 @@
          "misc.rkt"
          "blame.rkt"
          "guts.rkt"
+         "base.rkt"
          racket/stxparam)
 (require (for-syntax racket/base 
                      "helpers.rkt"
@@ -273,7 +274,7 @@
 (define-syntax (begin-lifted stx)
   (syntax-case stx ()
     [(_ expr)
-     (syntax-local-lift-expression #'expr)]))
+     (syntax-local-lift-expression (add-lifted-property #'expr))]))
 
 (define-syntax (define-opt/c stx)
   (syntax-case stx ()

racket/collects/racket/contract/private/provide.rkt

@@ -66,7 +66,6 @@
 
   ;; keys for syntax property used below
   (define rename-id-key (gensym 'contract:rename-id))
-  (define lifted-key    (gensym 'contract:lifted))
   (define neg-party-key (gensym 'contract:neg-party))
 
   ;; identifier? identifier? -> identifier?
@@ -74,11 +73,6 @@
   (define (add-rename-id rename-id partial-id)
     (syntax-property partial-id rename-id-key rename-id))
 
-  ;; syntax? -> syntax?
-  ;; tells clients that the expression is a lifted application
-  (define (add-lifted-property stx)
-    (syntax-property stx lifted-key #t))
-
   ;; identifier? -> identifier?
   ;; tells clients that the application of this id has an extra inserted argument
   (define (add-neg-party stx)
@@ -119,7 +113,8 @@
                           ;; No: lift the neg name creation
                           (syntax-local-introduce 
                            (syntax-local-lift-expression
-                            #'(quote-module-name))))])
+                            (add-lifted-property
+                             #'(quote-module-name)))))])
                 (when key (hash-set! global-saved-id-table key lifted-neg-party))
                 ;; Expand to a use of the lifted expression:
                 (define (adjust-location new-stx)