(with-eval-after-load 'scheme
  (defun my-scheme-region-extend-function ()
    (when (not (get-text-property (point) 'font-lock-multiline))
      (let ((new-beg
             (save-excursion
               (when (and (re-search-backward "#>\\|<#" nil t)
                          (equal (match-string 0) "#>"))
                 (point))))
            (new-end
             (save-excursion
               (when (and (re-search-forward "#>\\|<#" nil t)
                          (equal (match-string 0) "<#"))
                 (point)))))
        (when new-beg
          (setq font-lock-beg new-beg))
        (when new-end
          (setq font-lock-end new-end))
        (when (and new-beg new-end)
          (put-text-property beg end 'font-lock-multiline t))
        (or new-beg new-end))))

  (defun my-scheme-syntax-propertize-foreign (beg end)
    (when (search-forward "<#" nil t)
      (put-text-property (1- (point)) (point)
                         'syntax-table (string-to-syntax "> cn"))))

  (defun scheme-syntax-propertize (beg end)
    (goto-char beg)
    (scheme-syntax-propertize-sexp-comment (point) end)
    (funcall
     (syntax-propertize-rules
      ("\\(#\\);" (1 (prog1 "< cn"
                       (scheme-syntax-propertize-sexp-comment (point) end))))
      ("\\(#\\)>" (1 (prog1 "< cn"
                       (my-scheme-syntax-propertize-foreign (point) end)))))
     (point) end)))

(defun my-scheme-mode-setup ()
  (setq font-lock-extend-region-functions
        (cons 'my-scheme-region-extend-function
              font-lock-extend-region-functions)))

(add-hook 'scheme-mode-hook 'my-scheme-mode-setup)